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

fix a bug in the module lexer; it was returning the wrong length for the tokens

Browse Source 
it creates when the #lang line isn't well-formed (eg "#lang racke").

closes PR 12399

original commit: 11994bd4f8ea60b5a19ae1f1129bc5c072f3311f
This commit is contained in:
Robby Findler 2011-11-28 21:12:04 -06:00
parent d3dc21e2d3
commit e526d30337
1 changed files with 314 additions and 313 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

589
collects/framework/private/color.rkt
View File

@ -175,40 +175,40 @@ added get-regions
(let loop ([regions _regions] (let loop ([regions _regions]
[pos 0]) [pos 0])
(cond (cond
[(null? regions) (void)] [(null? regions) (void)]
[(pair? regions) [(pair? regions)
(let ([region (car regions)]) (let ([region (car regions)])
(unless (and (list? region) (unless (and (list? region)
(= 2 (length region)) (= 2 (length region))
(number? (list-ref region 0)) (number? (list-ref region 0))
(or (number? (list-ref region 1)) (or (number? (list-ref region 1))
(and (null? (cdr regions)) (and (null? (cdr regions))
(eq? 'end (list-ref region 1))))) (eq? 'end (list-ref region 1)))))
(error 'reset-regions (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" "got a region that is not a list of two numbers (or 'end if it is the last region): ~e, all regions ~e"
region region
regions)) regions))
(unless (and (<= pos (list-ref region 0)) (unless (and (<= pos (list-ref region 0))
(or (eq? 'end (list-ref region 1)) (or (eq? 'end (list-ref region 1))
(<= (list-ref region 0) (list-ref region 1)))) (<= (list-ref region 0) (list-ref region 1))))
(error 'reset-regions "found regions with numbers out of order ~e" regions)) (error 'reset-regions "found regions with numbers out of order ~e" regions))
(loop (cdr regions) (list-ref region 1)))] (loop (cdr regions) (list-ref region 1)))]
[else [else
(error 'reset-regions "expected a list of regions, got ~e" regions)])) (error 'reset-regions "expected a list of regions, got ~e" regions)]))
(set! lexer-states (set! lexer-states
(let loop ([old lexer-states] (let loop ([old lexer-states]
[new _regions]) [new _regions])
(cond (cond
[(null? new) null] [(null? new) null]
[(and (pair? old) [(and (pair? old)
(equal? (caar new) (lexer-state-start-pos (car old))) (equal? (caar new) (lexer-state-start-pos (car old)))
(equal? (cadar new) (lexer-state-end-pos (car old)))) (equal? (cadar new) (lexer-state-end-pos (car old))))
(cons (car old) (cons (car old)
(loop (cdr old) (cdr new)))] (loop (cdr old) (cdr new)))]
[else [else
(cons (make-new-lexer-state (caar new) (cadar new)) (cons (make-new-lexer-state (caar new) (cadar new))
(loop null (cdr new)))]))) (loop null (cdr new)))])))
(update-lexer-state-observers)) (update-lexer-state-observers))
@ -290,61 +290,67 @@ added get-regions
(sync-invalid ls)))) (sync-invalid ls))))
(define/private (re-tokenize ls in in-start-pos in-lexer-mode enable-suspend) (define/private (re-tokenize ls in in-start-pos in-lexer-mode enable-suspend)
(let-values ([(lexeme type data new-token-start new-token-end backup-delta new-lexer-mode) (enable-suspend #f)
(begin ;(define-values (_line1 _col1 pos-before) (port-next-location in))
(enable-suspend #f) (define-values (lexeme type data new-token-start new-token-end backup-delta new-lexer-mode)
(begin0 (get-token in in-start-pos in-lexer-mode))
(get-token in in-start-pos in-lexer-mode) ;(define-values (_line2 _col2 pos-after) (port-next-location in))
(enable-suspend #t)))]) (enable-suspend #t)
(unless (eq? 'eof type) (unless (eq? 'eof type)
(unless (exact-nonnegative-integer? new-token-start) (unless (exact-nonnegative-integer? new-token-start)
(error 'color:text<%> "expected an exact nonnegative integer for the token start, got ~e" new-token-start)) (error 'color:text<%> "expected an exact nonnegative integer for the token start, got ~e" new-token-start))
(unless (exact-nonnegative-integer? new-token-end) (unless (exact-nonnegative-integer? new-token-end)
(error 'color:text<%> "expected an exact nonnegative integer for the token end, got ~e" new-token-end)) (error 'color:text<%> "expected an exact nonnegative integer for the token end, got ~e" new-token-end))
(unless (exact-nonnegative-integer? backup-delta) (unless (exact-nonnegative-integer? backup-delta)
(error 'color:text<%> "expected an exact nonnegative integer for the backup delta, got ~e" backup-delta)) (error 'color:text<%> "expected an exact nonnegative integer for the backup delta, got ~e" backup-delta))
(unless (0 . < . (- new-token-end new-token-start)) (unless (0 . < . (- new-token-end new-token-start))
(error 'color:text<%> "expected the distance between the start and end position for each token to be positive, but start was ~e and end was ~e" new-token-start new-token-end)) (error 'color:text<%> "expected the distance between the start and end position for each token to be positive, but start was ~e and end was ~e" new-token-start new-token-end))
(enable-suspend #f) (enable-suspend #f)
#; (printf "~a at ~a to ~a\n" lexeme (+ in-start-pos (sub1 new-token-start)) #; (printf "~s 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-lexer-mode! ls new-lexer-mode) (unless (= len (- pos-after pos-before))
(sync-invalid ls) ;; this check requires the two calls to port-next-location to be also uncommented
(when (and should-color? (should-color-type? type) (not frozen?)) ;; when this check fails, bad things can happen non-deterministically later on
(set! colors (eprintf "pos changed bad ; len ~s pos-before ~s pos-after ~s (token ~s mode ~s)\n"
(cons len pos-before pos-after lexeme new-lexer-mode))
(let* ([style-name (token-sym->style type)] (set-lexer-state-current-pos! ls (+ len (lexer-state-current-pos ls)))
(color (send (get-style-list) find-named-style style-name)) (set-lexer-state-current-lexer-mode! ls new-lexer-mode)
(sp (+ in-start-pos (sub1 new-token-start))) (sync-invalid ls)
(ep (+ in-start-pos (sub1 new-token-end)))) (when (and should-color? (should-color-type? type) (not frozen?))
(λ () (set! colors
(change-style color sp ep #f))) (cons
colors))) (let* ([style-name (token-sym->style type)]
;; Using the non-spec version takes 3 times as long as the spec (color (send (get-style-list) find-named-style style-name))
;; version. In other words, the new greatly outweighs the tree (sp (+ in-start-pos (sub1 new-token-start)))
;; operations. (ep (+ in-start-pos (sub1 new-token-end))))
;;(insert-last! tokens (new token-tree% (length len) (data type))) (λ ()
(insert-last-spec! (lexer-state-tokens ls) len (make-data type new-lexer-mode backup-delta)) (change-style color sp ep #f)))
#; (show-tree (lexer-state-tokens ls)) colors)))
(send (lexer-state-parens ls) add-token data len) ;; Using the non-spec version takes 3 times as long as the spec
(cond ;; version. In other words, the new greatly outweighs the tree
((and (not (send (lexer-state-invalid-tokens ls) is-empty?)) ;; operations.
(= (lexer-state-invalid-tokens-start ls) ;;(insert-last! tokens (new token-tree% (length len) (data type)))
(lexer-state-current-pos ls)) (insert-last-spec! (lexer-state-tokens ls) len (make-data type new-lexer-mode backup-delta))
(equal? new-lexer-mode #; (show-tree (lexer-state-tokens ls))
(lexer-state-invalid-tokens-mode ls))) (send (lexer-state-parens ls) add-token data len)
(send (lexer-state-invalid-tokens ls) search-max!) (cond
(send (lexer-state-parens ls) merge-tree [(and (not (send (lexer-state-invalid-tokens ls) is-empty?))
(send (lexer-state-invalid-tokens ls) get-root-end-position)) (= (lexer-state-invalid-tokens-start ls)
(insert-last! (lexer-state-tokens ls) (lexer-state-current-pos ls))
(lexer-state-invalid-tokens ls)) (equal? new-lexer-mode
(set-lexer-state-invalid-tokens-start! ls +inf.0) (lexer-state-invalid-tokens-mode ls)))
(enable-suspend #t)) (send (lexer-state-invalid-tokens ls) search-max!)
(else (send (lexer-state-parens ls) merge-tree
(enable-suspend #t) (send (lexer-state-invalid-tokens ls) get-root-end-position))
(re-tokenize ls in in-start-pos new-lexer-mode enable-suspend))))))) (insert-last! (lexer-state-tokens ls)
(lexer-state-invalid-tokens ls))
(set-lexer-state-invalid-tokens-start! ls +inf.0)
(enable-suspend #t)]
[else
(enable-suspend #t)
(re-tokenize ls in in-start-pos new-lexer-mode enable-suspend)]))))
(define/private (show-tree t) (define/private (show-tree t)
(printf "Tree:\n") (printf "Tree:\n")
@ -373,56 +379,56 @@ added get-regions
(unless (lexer-state-up-to-date? ls) (unless (lexer-state-up-to-date? ls)
(sync-invalid ls)) (sync-invalid ls))
(cond (cond
((lexer-state-up-to-date? ls) ((lexer-state-up-to-date? ls)
(let-values (((orig-token-start orig-token-end valid-tree invalid-tree orig-data) (let-values (((orig-token-start orig-token-end valid-tree invalid-tree orig-data)
(split-backward ls (lexer-state-tokens ls) edit-start-pos))) (split-backward ls (lexer-state-tokens ls) edit-start-pos)))
(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)
(set-lexer-state-invalid-tokens-start! (set-lexer-state-invalid-tokens-start!
ls ls
(if (send (lexer-state-invalid-tokens ls) is-empty?) (if (send (lexer-state-invalid-tokens ls) is-empty?)
+inf.0 +inf.0
(+ (lexer-state-start-pos ls) orig-token-end change-length))) (+ (lexer-state-start-pos ls) orig-token-end change-length)))
(set-lexer-state-invalid-tokens-mode! ls (and orig-data (data-lexer-mode orig-data))) (set-lexer-state-invalid-tokens-mode! ls (and orig-data (data-lexer-mode orig-data)))
(let ([start (+ (lexer-state-start-pos ls) orig-token-start)]) (let ([start (+ (lexer-state-start-pos ls) orig-token-start)])
(set-lexer-state-current-pos! ls start) (set-lexer-state-current-pos! ls start)
(set-lexer-state-current-lexer-mode! ls (set-lexer-state-current-lexer-mode! ls
(if (= start (lexer-state-start-pos ls)) (if (= start (lexer-state-start-pos ls))
#f #f
(begin (begin
(send valid-tree search-max!) (send valid-tree search-max!)
(data-lexer-mode (send valid-tree get-root-data)))))) (data-lexer-mode (send valid-tree get-root-data))))))
(set-lexer-state-up-to-date?! ls #f) (set-lexer-state-up-to-date?! ls #f)
(update-lexer-state-observers) (update-lexer-state-observers)
(queue-callback (λ () (colorer-callback)) #f))) (queue-callback (λ () (colorer-callback)) #f)))
((>= edit-start-pos (lexer-state-invalid-tokens-start ls)) ((>= edit-start-pos (lexer-state-invalid-tokens-start ls))
(let-values (((tok-start tok-end valid-tree invalid-tree orig-data) (let-values (((tok-start tok-end valid-tree invalid-tree orig-data)
(split-backward ls (lexer-state-invalid-tokens ls) edit-start-pos))) (split-backward ls (lexer-state-invalid-tokens ls) edit-start-pos)))
(set-lexer-state-invalid-tokens! ls invalid-tree) (set-lexer-state-invalid-tokens! ls invalid-tree)
(set-lexer-state-invalid-tokens-start! (set-lexer-state-invalid-tokens-start!
ls ls
(+ (lexer-state-invalid-tokens-start ls) tok-end change-length)) (+ (lexer-state-invalid-tokens-start ls) tok-end change-length))
(set-lexer-state-invalid-tokens-mode! ls (and orig-data (data-lexer-mode orig-data))))) (set-lexer-state-invalid-tokens-mode! ls (and orig-data (data-lexer-mode orig-data)))))
((> edit-start-pos (lexer-state-current-pos ls)) ((> edit-start-pos (lexer-state-current-pos ls))
(set-lexer-state-invalid-tokens-start! (set-lexer-state-invalid-tokens-start!
ls ls
(+ change-length (lexer-state-invalid-tokens-start ls)))) (+ change-length (lexer-state-invalid-tokens-start ls))))
(else (else
(let-values (((tok-start tok-end valid-tree invalid-tree data) (let-values (((tok-start tok-end valid-tree invalid-tree data)
(split-backward ls (lexer-state-tokens ls) edit-start-pos))) (split-backward ls (lexer-state-tokens ls) edit-start-pos)))
(send (lexer-state-parens ls) truncate tok-start) (send (lexer-state-parens ls) truncate tok-start)
(set-lexer-state-tokens! ls valid-tree) (set-lexer-state-tokens! ls valid-tree)
(set-lexer-state-invalid-tokens-start! ls (+ change-length (lexer-state-invalid-tokens-start ls))) (set-lexer-state-invalid-tokens-start! ls (+ change-length (lexer-state-invalid-tokens-start ls)))
(let ([start (+ (lexer-state-start-pos ls) tok-start)]) (let ([start (+ (lexer-state-start-pos ls) tok-start)])
(set-lexer-state-current-pos! ls start) (set-lexer-state-current-pos! ls start)
(set-lexer-state-current-lexer-mode! (set-lexer-state-current-lexer-mode!
ls ls
(if (= start (lexer-state-start-pos ls)) (if (= start (lexer-state-start-pos ls))
#f #f
(begin (begin
(send valid-tree search-max!) (send valid-tree search-max!)
(data-lexer-mode (send valid-tree get-root-data)))))))))) (data-lexer-mode (send valid-tree get-root-data))))))))))
(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?)
@ -447,35 +453,30 @@ added get-regions
(set! tok-cor (set! tok-cor
(coroutine (coroutine
(λ (enable-suspend) (λ (enable-suspend)
(parameterize ((port-count-lines-enabled #t)) (parameterize ((port-count-lines-enabled #t))
(when (getenv "PLTDRDRTEST") (for-each
(printf "colorer-driver: lexer-states ~s\n" lexer-states) (lambda (ls)
(printf "colorer-driver: text ~s\n" (send this get-text))) (re-tokenize ls
(for-each (begin
(lambda (ls) (enable-suspend #f)
(re-tokenize ls (begin0
(begin
(enable-suspend #f)
(begin0
(open-input-text-editor this (open-input-text-editor this
(lexer-state-current-pos ls) (lexer-state-current-pos ls)
(lexer-state-end-pos ls) (lexer-state-end-pos ls)
(λ (x) #f)) (λ (x) #f))
(enable-suspend #t))) (enable-suspend #t)))
(lexer-state-current-pos ls) (lexer-state-current-pos ls)
(lexer-state-current-lexer-mode ls) (lexer-state-current-lexer-mode ls)
enable-suspend)) enable-suspend))
lexer-states))))) lexer-states)))))
(set! rev (get-revision-number))) (set! rev (get-revision-number)))
(with-handlers ((exn:fail? (with-handlers ((exn:fail?
(λ (exn) (λ (exn)
(parameterize ((print-struct #t)) (parameterize ((print-struct #t))
(when (getenv "PLTDRDRTEST") ((error-display-handler)
(printf "colorer-driver: error ~a\n" (and (exn? exn) (exn-message exn)))) (format "exception in colorer thread: ~s" exn)
((error-display-handler) exn))
(format "exception in colorer thread: ~s" exn) (set! tok-cor #f))))
exn))
(set! tok-cor #f))))
#;(printf "begin lexing\n") #;(printf "begin lexing\n")
(when (coroutine-run 10 tok-cor) (when (coroutine-run 10 tok-cor)
(for-each (lambda (ls) (for-each (lambda (ls)
@ -493,13 +494,13 @@ added get-regions
(define/private (colorer-callback) (define/private (colorer-callback)
(cond (cond
((is-locked?) ((is-locked?)
(set! restart-callback #t)) (set! restart-callback #t))
(else (else
(unless (in-edit-sequence?) (unless (in-edit-sequence?)
(colorer-driver)) (colorer-driver))
(unless (andmap lexer-state-up-to-date? lexer-states) (unless (andmap lexer-state-up-to-date? lexer-states)
(queue-callback (λ () (colorer-callback)) #f))))) (queue-callback (λ () (colorer-callback)) #f)))))
;; Must not be called when the editor is locked ;; Must not be called when the editor is locked
(define/private (finish-now) (define/private (finish-now)
@ -569,53 +570,53 @@ added get-regions
;; See docs ;; See docs
(define/public thaw-colorer (define/public thaw-colorer
(lambda ((recolor? #t) (lambda ((recolor? #t)
(retokenize? #f)) (retokenize? #f))
(when frozen? (when frozen?
(set! frozen? #f) (set! frozen? #f)
(cond (cond
(stopped? (stopped?
(stop-colorer)) (stop-colorer))
((or force-recolor-after-freeze recolor?) ((or force-recolor-after-freeze recolor?)
(cond (cond
(retokenize? (retokenize?
(let ((tn token-sym->style) (let ((tn token-sym->style)
(gt get-token) (gt get-token)
(p pairs)) (p pairs))
(stop-colorer (not should-color?)) (stop-colorer (not should-color?))
(start-colorer tn gt p))) (start-colorer tn gt p)))
(else (else
(begin-edit-sequence #f #f) (begin-edit-sequence #f #f)
(finish-now) (finish-now)
(when should-color? (when should-color?
(for-each (for-each
(lambda (ls) (lambda (ls)
(let ([tokens (lexer-state-tokens ls)] (let ([tokens (lexer-state-tokens ls)]
[start-pos (lexer-state-start-pos ls)]) [start-pos (lexer-state-start-pos ls)])
(send tokens for-each (send tokens for-each
(λ (start len data) (λ (start len data)
(let ([type (data-type data)]) (let ([type (data-type data)])
(when (should-color-type? type) (when (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-pos start))
(ep (+ start-pos (+ start len)))) (ep (+ start-pos (+ start len))))
(change-style color sp ep #f)))))))) (change-style color sp ep #f))))))))
lexer-states)) lexer-states))
(end-edit-sequence)))))))) (end-edit-sequence))))))))
(define/private (toggle-color on?) (define/private (toggle-color on?)
(cond (cond
((and frozen? (not (equal? on? should-color?))) ((and frozen? (not (equal? on? should-color?)))
(set! should-color? on?) (set! should-color? on?)
(set! force-recolor-after-freeze #t)) (set! force-recolor-after-freeze #t))
((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-all)) (do-insert/delete-all))
((and should-color? (not on?)) ((and should-color? (not on?))
(set! should-color? on?) (set! should-color? on?)
(clear-colors)))) (clear-colors))))
;; see docs ;; see docs
(define/public (force-stop-colorer stop?) (define/public (force-stop-colorer stop?)
@ -648,8 +649,8 @@ added get-regions
(set! clear-old-locations (set! clear-old-locations
(let ([old clear-old-locations]) (let ([old clear-old-locations])
(λ () (λ ()
(old) (old)
(off)))))) (off))))))
(define in-match-parens? #f) (define in-match-parens? #f)
@ -751,17 +752,17 @@ added get-regions
(send (lexer-state-parens ls) match-forward (send (lexer-state-parens ls) match-forward
(- position (lexer-state-start-pos ls))))) (- position (lexer-state-start-pos ls)))))
(cond (cond
((f-match-false-error ls start end error) ((f-match-false-error ls 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 (+ (lexer-state-start-pos ls) end))) (let ((match-pos (+ (lexer-state-start-pos ls) end)))
(cond (cond
((<= match-pos cutoff) match-pos) ((<= match-pos cutoff) match-pos)
(else #f)))) (else #f))))
((and start end error) #f) ((and start end error) #f)
(else (else
(skip-past-token ls position)))))))) (skip-past-token ls position))))))))
(define/private (skip-past-token ls position) (define/private (skip-past-token ls position)
(let-values (((tok-start tok-end) (let-values (((tok-start tok-end)
@ -772,18 +773,18 @@ added get-regions
(values (send (lexer-state-tokens ls) get-root-start-position) (values (send (lexer-state-tokens ls) get-root-start-position)
(send (lexer-state-tokens ls) get-root-end-position))))) (send (lexer-state-tokens ls) get-root-end-position)))))
(cond (cond
((or (send (lexer-state-parens ls) is-close-pos? tok-start) ((or (send (lexer-state-parens ls) is-close-pos? tok-start)
(= (+ (lexer-state-start-pos ls) tok-end) position)) (= (+ (lexer-state-start-pos ls) tok-end) position))
#f) #f)
(else (else
(+ (lexer-state-start-pos ls) tok-end))))) (+ (lexer-state-start-pos ls) tok-end)))))
;; See docs ;; See docs
(define/public (backward-match position cutoff) (define/public (backward-match position cutoff)
(let ((x (internal-backward-match position cutoff))) (let ((x (internal-backward-match position cutoff)))
(cond (cond
((eq? x 'open) #f) ((eq? x 'open) #f)
(else x)))) (else x))))
(define/private (internal-backward-match position cutoff) (define/private (internal-backward-match position cutoff)
(when stopped? (when stopped?
@ -796,27 +797,27 @@ added get-regions
(let-values (((start end error) (let-values (((start end error)
(send (lexer-state-parens ls) match-backward (- position start-pos)))) (send (lexer-state-parens ls) match-backward (- position start-pos))))
(cond (cond
((and start end (not error)) ((and start end (not error))
(let ((match-pos (+ start-pos start))) (let ((match-pos (+ start-pos start)))
(cond (cond
((>= match-pos cutoff) match-pos) ((>= match-pos cutoff) match-pos)
(else #f)))) (else #f))))
((and start end error) #f) ((and start end error) #f)
(else (else
(let-values (((tok-start tok-end) (let-values (((tok-start tok-end)
(begin (begin
(send (lexer-state-tokens ls) search! (send (lexer-state-tokens ls) search!
(if (> position start-pos) (if (> position start-pos)
(- position start-pos 1) (- position start-pos 1)
0)) 0))
(values (send (lexer-state-tokens ls) get-root-start-position) (values (send (lexer-state-tokens ls) get-root-start-position)
(send (lexer-state-tokens ls) get-root-end-position))))) (send (lexer-state-tokens ls) get-root-end-position)))))
(cond (cond
((or (send (lexer-state-parens ls) is-open-pos? tok-start) ((or (send (lexer-state-parens ls) is-open-pos? tok-start)
(= (+ start-pos tok-start) position)) (= (+ start-pos tok-start) position))
'open) 'open)
(else (else
(+ start-pos tok-start)))))))))) (+ start-pos tok-start))))))))))
;; See docs ;; See docs
(define/public (backward-containing-sexp position cutoff) (define/public (backward-containing-sexp position cutoff)
@ -825,9 +826,9 @@ added get-regions
(let loop ((cur-pos position)) (let loop ((cur-pos position))
(let ((p (internal-backward-match cur-pos cutoff))) (let ((p (internal-backward-match cur-pos cutoff)))
(cond (cond
((eq? 'open p) cur-pos) ((eq? 'open p) cur-pos)
((not p) #f) ((not p) #f)
(else (loop p)))))) (else (loop p))))))
;; Determines whether a position is a 'comment, 'string, etc. ;; Determines whether a position is a 'comment, 'string, etc.
(define/public (classify-position position) (define/public (classify-position position)
@ -852,8 +853,8 @@ added get-regions
(let ([ls (find-ls position)]) (let ([ls (find-ls position)])
(if ls (if ls
(let ([tokens (lexer-state-tokens ls)]) (let ([tokens (lexer-state-tokens ls)])
(tokenize-to-pos ls position) (tokenize-to-pos ls position)
(send tokens search! (- position (lexer-state-start-pos ls))) (send tokens search! (- position (lexer-state-start-pos ls)))
(values tokens ls)) (values tokens ls))
(values #f #f)))) (values #f #f))))
@ -874,55 +875,55 @@ added get-regions
[end-pos (lexer-state-end-pos ls)] [end-pos (lexer-state-end-pos ls)]
[tokens (lexer-state-tokens ls)]) [tokens (lexer-state-tokens ls)])
(cond (cond
((and (eq? direction 'forward) ((and (eq? direction 'forward)
(>= position (if (eq? 'end end-pos) (last-position) end-pos))) (>= position (if (eq? 'end end-pos) (last-position) end-pos)))
position) position)
((and (eq? direction 'backward) (<= position start-pos)) ((and (eq? direction 'backward) (<= position start-pos))
position) position)
(else (else
(tokenize-to-pos ls position) (tokenize-to-pos ls position)
(send tokens search! (- (if (eq? direction 'backward) (sub1 position) position) (send tokens search! (- (if (eq? direction 'backward) (sub1 position) position)
start-pos)) start-pos))
(cond (cond
((and (send tokens get-root-data) ((and (send tokens get-root-data)
(or (eq? 'white-space (data-type (send tokens get-root-data))) (or (eq? 'white-space (data-type (send tokens get-root-data)))
(and comments? (eq? 'comment (data-type (send tokens get-root-data)))))) (and comments? (eq? 'comment (data-type (send tokens get-root-data))))))
(skip-whitespace (+ start-pos (skip-whitespace (+ start-pos
(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 (get-close-paren pos closers continue-after-non-paren?) (define/private (get-close-paren pos closers continue-after-non-paren?)
(cond (cond
((null? closers) #f) ((null? closers) #f)
(else (else
(let* ((c (car closers)) (let* ((c (car closers))
(l (string-length c))) (l (string-length c)))
(let ([ls (find-ls pos)]) (let ([ls (find-ls pos)])
(if ls (if ls
(let ([start-pos (lexer-state-start-pos ls)]) (let ([start-pos (lexer-state-start-pos ls)])
(insert c pos) (insert c pos)
(let ((cls (classify-position pos))) (let ((cls (classify-position pos)))
(if (eq? cls 'parenthesis) (if (eq? cls 'parenthesis)
(let ((m (backward-match (+ l pos) start-pos))) (let ((m (backward-match (+ l pos) start-pos)))
(cond (cond
((and m ((and m
(send (lexer-state-parens ls) is-open-pos? (- m start-pos)) (send (lexer-state-parens ls) is-open-pos? (- m start-pos))
(send (lexer-state-parens ls) is-close-pos? (- pos start-pos))) (send (lexer-state-parens ls) is-close-pos? (- pos start-pos)))
(delete pos (+ l pos)) (delete pos (+ l pos))
c) c)
(else (else
(delete pos (+ l pos)) (delete pos (+ l pos))
(get-close-paren pos (cdr closers) #t)))) (get-close-paren pos (cdr closers) #t))))
(begin (begin
(delete pos (+ l pos)) (delete pos (+ l pos))
(if continue-after-non-paren? (if continue-after-non-paren?
(get-close-paren pos (cdr closers) #t) (get-close-paren pos (cdr closers) #t)
#f))))) #f)))))
c)))))) c))))))
(inherit insert delete flash-on on-default-char) (inherit insert delete flash-on on-default-char)
;; See docs ;; See docs