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

add set-get-token to color:text-mode<%>

Browse Source
This commit is contained in:
Robby Findler 2016-12-23 11:49:26 -06:00
parent 27569696b3
commit 141eee8cbc
3 changed files with 52 additions and 19 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

10
gui-doc/scribblings/framework/color.scrbl
View File

@ -376,7 +376,15 @@
@defclass[color:text% (color:text-mixin text:keymap%) ()]{}
@definterface[color:text-mode<%> ()]{}
@definterface[color:text-mode<%> ()]{
@defmethod[(set-get-token [get-token procedure?]) void?]{
Sets the @racket[get-token] function used to color the contents
of the editor.
See @method[color:text<%> start-colorer]'s @racket[get-token] argument
for the contract on this method's @racket[get-token] argument.
}
}
@defmixin[color:text-mode-mixin (mode:surrogate-text<%>) (color:text-mode<%>)]{
This mixin adds coloring functionality to the mode.

16
gui-lib/framework/private/color.rkt
View File

@ -264,13 +264,13 @@ added get-regions
(spell-checking-values-changed)))
(define/private (spell-checking-values-changed)
(reset-tokens)
(start-colorer token-sym->style get-token pairs))
(_start-colorer token-sym->style get-token pairs))
(define current-dict (preferences:get 'framework:aspell-dict))
(define/public (set-spell-current-dict d)
(unless (equal? d current-dict)
(set! current-dict d)
(reset-tokens)
(start-colorer token-sym->style get-token pairs)))
(_start-colorer token-sym->style get-token pairs)))
(define/public (get-spell-current-dict) current-dict)
;; ---------------------- Multi-threading ---------------------------
@ -609,7 +609,7 @@ added get-regions
(loop)))))
;; See docs
(define/public (start-colorer token-sym->style- get-token- pairs-)
(define/private (_start-colorer token-sym->style- get-token- pairs-)
(unless force-stop?
(set! stopped? #f)
(reset-tokens)
@ -630,6 +630,9 @@ added get-regions
lexer-states)
;; (set! timer (current-milliseconds))
(do-insert/delete-all)))
(define/public (start-colorer token-sym->style- get-token- pairs-)
(_start-colorer token-sym->style- get-token- pairs-))
;; See docs
(define/public stop-colorer
@ -681,7 +684,7 @@ added get-regions
(gt get-token)
(p pairs))
(stop-colorer (not should-color?))
(start-colorer tn gt p)))
(_start-colorer tn gt p)))
(else
(begin-edit-sequence #f #f)
(finish-now)
@ -1319,7 +1322,7 @@ added get-regions
(define -text% (text-mixin text:keymap%))
(define -text-mode<%> (interface ()))
(define -text-mode<%> (interface () set-get-token))
(define text-mode-mixin
(mixin (mode:surrogate-text<%>) (-text-mode<%>)
@ -1336,6 +1339,9 @@ added get-regions
(define/override (on-enable-surrogate text)
(super on-enable-surrogate text)
(send text start-colorer token-sym->style get-token matches))
(define/public (set-get-token _get-token)
(set! get-token _get-token))
(super-new)))

45
gui-lib/framework/private/racket.rkt
View File

@ -475,7 +475,7 @@
position-location get-dc)
(define private-racket-container-keymap (new keymap:aug-keymap%))
(define/public (get-private-racket-container-keymap) private-racket-container-keymap)
(define/public (get-private-racket-container-keymap) private-racket-container-keymap)
(define/override (get-keymaps)
(editor:add-after-user-keymap private-racket-container-keymap
@ -1353,16 +1353,6 @@
(preferences:add-callback
'framework:tabify
(lambda (k v) (set! tabify-pref v)))
(define/private (racket-lexer-wrapper in offset mode)
(define-values (lexeme type paren start end backup-delta new-mode)
(module-lexer/waived in offset mode))
(cond
[(and (eq? type 'symbol)
(string? lexeme)
(get-head-sexp-type-from-prefs lexeme tabify-pref))
(values lexeme 'keyword paren start end backup-delta new-mode)]
[else
(values lexeme type paren start end backup-delta new-mode)]))
(define/override (put-file text sup directory default-name)
;; don't call the surrogate's super, since it sets the default extension
@ -1371,13 +1361,42 @@
(parameterize ([finder:default-extension "rkt"])
(sup directory default-name))]
[else (sup directory default-name)]))
(super-new (get-token (lambda (in offset mode) (racket-lexer-wrapper in offset mode)))
(define/override (set-get-token get-token-)
(super set-get-token (wrap-get-token get-token- (λ () tabify-pref))))
(super-new (get-token (wrap-get-token module-lexer/waived (λ () tabify-pref)))
(token-sym->style short-sym->style-name)
(matches '((|(| |)|)
(|[| |]|)
(|{| |}|))))))
(define (wrap-get-token get-token- get-tabify-pref)
(define wrapped-get-token
(cond
[(procedure-arity-includes? get-token- 3)
(λ (in offset mode)
(define-values (lexeme type paren start end backup-delta new-mode)
(get-token- in offset mode))
(cond
[(and (eq? type 'symbol)
(string? lexeme)
(get-head-sexp-type-from-prefs lexeme (get-tabify-pref)))
(values lexeme 'keyword paren start end backup-delta new-mode)]
[else
(values lexeme type paren start end backup-delta new-mode)]))]
[else
(λ (in)
(define-values (lexeme type paren start end) (get-token- in))
(cond
[(and (eq? type 'symbol)
(string? lexeme)
(get-head-sexp-type-from-prefs lexeme (get-tabify-pref)))
(values lexeme 'keyword paren start end)]
[else
(values lexeme type paren start end)]))]))
wrapped-get-token)
;; get-head-sexp-type-from-prefs : string (list ht regexp regexp regexp)
;; -> (or/c #f 'lambda 'define 'begin 'for/fold)
(define (get-head-sexp-type-from-prefs text pref)