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

The initial import of on-the-fly lexical coloring and parenthesis matching.

Browse Source 
original commit: 12f2192322a8544642529bccc197214d02316689
This commit is contained in:
Scott Owens 2003-11-05 04:48:41 +00:00
parent 88034d298b
commit 8ba1181bd5
4 changed files with 754 additions and 151 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

245
collects/framework/private/color-prefs.ss Normal file
View File

@ -0,0 +1,245 @@
(module color-prefs mzscheme
(require (lib "class.ss")
(lib "unitsig.ss")
(lib "mred.ss" "mred")
(lib "string-constant.ss" "string-constants")
"sig.ss")
(provide color-prefs@)
(define color-prefs@
(unit/sig framework:color-prefs^
(import [preferences : framework:preferences^]
[editor : framework:editor^])
(define standard-style-list-text% (editor:standard-style-list-mixin text%))
(define color-selection%
(class horizontal-panel%
(init symbol prefix)
(super-instantiate () (style '(border)))
(define sym (string->symbol (format "~a:~a" prefix symbol)))
(define delta (preferences:get sym))
(define style-name (symbol->string sym))
(define c (make-object editor-canvas% this
#f
(list 'hide-hscroll
'hide-vscroll)))
(send c set-line-count 1)
(send c allow-tab-exit #t)
(define e (new (class standard-style-list-text%
(inherit change-style get-style-list)
(rename [super-after-insert after-insert])
(override after-insert)
(define (after-insert pos offset)
(super-after-insert pos offset)
(let ([style (send (get-style-list)
find-named-style
style-name)])
(change-style style pos (+ pos offset) #f)))
(super-instantiate ()))))
(preferences:add-callback sym
(lambda (sym v)
(set-slatex-style sym v)
#t))
(set-slatex-style sym delta)
(define (make-check name on off)
(let* ([c (lambda (check command)
(if (send check get-value)
(on)
(off))
(preferences:set sym delta))]
[check (make-object check-box% name this c)])
check))
(send c set-editor e)
(send* e
(insert (symbol->string symbol))
(set-position 0))
(define slant-check
(make-check (string-constant cs-italic)
(lambda ()
(send delta set-style-on 'slant)
(send delta set-style-off 'base))
(lambda ()
(send delta set-style-on 'base)
(send delta set-style-off 'slant))))
(define bold-check
(make-check (string-constant cs-bold)
(lambda ()
(send delta set-weight-on 'bold)
(send delta set-weight-off 'base))
(lambda ()
(send delta set-weight-on 'base)
(send delta set-weight-off 'bold))))
(define underline-check
(make-check (string-constant cs-underline)
(lambda ()
(send delta set-underlined-on #t)
(send delta set-underlined-off #f))
(lambda ()
(send delta set-underlined-off #t)
(send delta set-underlined-on #f))))
(define color-button
(and (>= (get-display-depth) 8)
(make-object button%
(string-constant cs-change-color)
this
(lambda (color-button evt)
(let* ([add (send delta get-foreground-add)]
[color (make-object color%
(send add get-r)
(send add get-g)
(send add get-b))]
[users-choice
(get-color-from-user
(format "Choose a color for ~a"
(symbol->string symbol))
(send color-button get-top-level-window)
color)])
(when users-choice
(send delta set-delta-foreground users-choice)
(preferences:set sym delta)))))))
(define style (send (send e get-style-list) find-named-style style-name))
(send slant-check set-value (eq? (send style get-style) 'slant))
(send bold-check set-value (eq? (send style get-weight) 'bold))
(send underline-check set-value (send style get-underlined))))
(define add/mult-set
(lambda (m v)
(send m set (car v) (cadr v) (caddr v))))
(define add/mult-get
(lambda (m)
(let ([b1 (box 0)]
[b2 (box 0)]
[b3 (box 0)])
(send m get b1 b2 b3)
(map unbox (list b1 b2 b3)))))
(define style-delta-get/set
(list (cons (lambda (x) (send x get-alignment-off))
(lambda (x v) (send x set-alignment-off v)))
(cons (lambda (x) (send x get-alignment-on))
(lambda (x v) (send x set-alignment-on v)))
(cons (lambda (x) (add/mult-get (send x get-background-add)))
(lambda (x v) (add/mult-set (send x get-background-add) v)))
(cons (lambda (x) (add/mult-get (send x get-background-mult)))
(lambda (x v) (add/mult-set (send x get-background-mult) v)))
(cons (lambda (x) (send x get-face))
(lambda (x v) (send x set-face v)))
(cons (lambda (x) (send x get-family))
(lambda (x v) (send x set-family v)))
(cons (lambda (x) (add/mult-get (send x get-foreground-add)))
(lambda (x v) (add/mult-set (send x get-foreground-add) v)))
(cons (lambda (x) (add/mult-get (send x get-foreground-mult)))
(lambda (x v) (add/mult-set (send x get-foreground-mult) v)))
(cons (lambda (x) (send x get-size-add))
(lambda (x v) (send x set-size-add v)))
(cons (lambda (x) (send x get-size-mult))
(lambda (x v) (send x set-size-mult v)))
(cons (lambda (x) (send x get-style-off))
(lambda (x v) (send x set-style-off v)))
(cons (lambda (x) (send x get-style-on))
(lambda (x v) (send x set-style-on v)))
(cons (lambda (x) (send x get-underlined-off))
(lambda (x v) (send x set-underlined-off v)))
(cons (lambda (x) (send x get-underlined-on))
(lambda (x v) (send x set-underlined-on v)))
(cons (lambda (x) (send x get-weight-off))
(lambda (x v) (send x set-weight-off v)))
(cons (lambda (x) (send x get-weight-on))
(lambda (x v) (send x set-weight-on v)))))
(define (marshall-style style)
(map (lambda (fs) ((car fs) style)) style-delta-get/set))
(define (unmarshall-style info)
(let ([style (make-object style-delta%)])
(for-each (lambda (fs v) ((cdr fs) style v)) style-delta-get/set info)
style))
(define (set-default sym code-style)
(preferences:set-default
sym
code-style
(lambda (x)
(is-a? x style-delta%)))
(preferences:set-un/marshall sym marshall-style unmarshall-style))
; a symbol naming the style and a delta to set it to
(define set-slatex-style
(lambda (sym delta)
(let* ([style-list (editor:get-standard-style-list)]
[name (symbol->string sym)]
[style (send style-list find-named-style name)])
(if style
(send style set-delta delta)
(send style-list new-named-style name
(send style-list find-or-create-style
(send style-list find-named-style "Standard")
delta))))))
(define (make-style-delta color bold? underline? italic?)
(let ((sd (make-object style-delta%)))
(send sd set-delta-foreground color)
(cond
(bold?
(send sd set-weight-on 'bold)
(send sd set-weight-off 'base))
(else
(send sd set-weight-on 'base)
(send sd set-weight-off 'bold)))
(send sd set-underlined-on underline?)
(send sd set-underlined-off (not underline?))
(cond
(italic?
(send sd set-style-on 'italic)
(send sd set-style-off 'base))
(else
(send sd set-style-on 'base)
(send sd set-style-off 'italic)))
sd))
(define color-selection-panel%
(class vertical-panel%
(init symbols prefix)
(super-instantiate ())
(for-each
(lambda (s)
(new color-selection% (prefix prefix) (symbol s) (parent this)))
symbols)
))
(define (add tab-name symbols/defaults)
(let* ((prefix (string->symbol (format "syntax-coloring:~a" tab-name)))
(active-pref (string->symbol (format "~a:active" prefix))))
(for-each (lambda (s)
(set-default (string->symbol (format "~a:~a" prefix (car s)))
(cadr s)))
symbols/defaults)
(preferences:set-default active-pref #t (lambda (x) #t))
(preferences:add-panel `("Editing" "Colors" ,tab-name)
(lambda (p)
(let ((vp (new vertical-panel% (parent p))))
(new color-selection-panel%
(parent vp)
(prefix prefix)
(symbols (map car symbols/defaults)))
(let ((cb (new check-box%
(parent vp)
(label "Activate Coloring?")
(callback (lambda (checkbox y)
(preferences:set
active-pref
(send checkbox get-value)))))))
(send cb set-value (preferences:get active-pref)))
vp))))))))

440
collects/framework/private/color.ss Normal file
View File

@ -0,0 +1,440 @@
(module color mzscheme
(require (lib "class.ss")
(lib "etc.ss")
(lib "unitsig.ss")
(lib "mred.ss" "mred")
(lib "token-tree.ss" "syntax-color")
(lib "paren-tree.ss" "syntax-color")
"sig.ss"
"../macro.ss")
(provide color@)
(define color@
(unit/sig framework:color^
(import [preferences : framework:preferences^]
[icon : framework:icon^]
[mode : framework:mode^]
[text : framework:text^])
(rename [-text<%> text<%>]
[-text% text%]
[-text-mode<%> text-mode<%>])
(define-local-member-name set-start-pos set-end-pos reset-tokens)
(define -text<%>
(interface ()
start-colorer
stop-colorer))
(define interactions-mixin<%>
(interface ()
reset-tokens
set-start-pos
set-end-pos))
(define text-mixin
(mixin (text:basic<%>) (-text<%> interactions-mixin<%>)
;; ---------------------- Lexing state ----------------------------------
;; The tree of valid tokens, starting at start-pos
(define tokens (new token-tree%))
;; The tree of tokens that have been invalidated by an edit
;; but might still be valid.
(define invalid-tokens (new token-tree%))
;; The position right before the invalid-tokens tree
(define invalid-tokens-start +inf.0)
;; The position right before the next token to be read
(define current-pos start-pos)
;; The lexer
(define get-token #f)
;; If the tree is completed
(define up-to-date? #t)
(define stopped? #t)
;; ---------------------- Parnethesis matching --------------------------
(define pairs '())
(define parens (new paren-tree% (matches pairs)))
;; ---------------------- Interactions state ----------------------------
;; The positions right before and right after the area to be tokenized
(define start-pos 0)
(define end-pos 'end)
(define/public (set-start-pos x)
(set! start-pos x))
(define/public (set-end-pos x)
(set! end-pos x))
;; ---------------------- Preferences -----------------------------------
(define should-color? #t)
(define remove-prefs-callback-thunk #f)
(define prefix #f)
;; ---------------------- Multi-threading -------------------------------
;; A list of thunks that color the buffer
(define colors null)
;; The thread handle to the background colorer
(define background-thread #f)
;; Prevent the background thread from being put to sleep while modifying
;; global state
(define lock (make-semaphore 1))
(inherit change-style begin-edit-sequence end-edit-sequence highlight-range
get-style-list in-edit-sequence? get-start-position get-end-position
local-edit-sequence? get-styles-fixed has-focus?)
(define/public (reset-tokens)
(send tokens reset-tree)
(send invalid-tokens reset-tree)
(set! invalid-tokens-start +inf.0)
(set! up-to-date? #t)
(set! parens (new paren-tree% (matches pairs)))
(set! current-pos start-pos)
(set! colors null)
(modify))
(define (modify)
(when background-thread
(break-thread background-thread)))
(define (color)
(unless (null? colors)
((car colors))
(set! colors (cdr colors))
(color)))
(define (sync-invalid)
(when (and (not (send invalid-tokens is-empty?))
(< invalid-tokens-start current-pos))
(send invalid-tokens search-min!)
(let ((length (send invalid-tokens get-root-length)))
(send invalid-tokens remove-root!)
(set! invalid-tokens-start (+ invalid-tokens-start length)))
(sync-invalid)))
;; re-tokenize should be called with breaks enabled and exit with breaks disabled
;; re-tokenize should be called when lock is not held. When it exits, the lock
;; will be held.
(define (re-tokenize in in-start-pos)
(let-values (((type data new-token-start new-token-end) (get-token in)))
;; breaks must be disabled before the semaphore wait so we can't be
;; broken out of the critical section
(break-enabled #f)
;; If a break occurs while we are suspended, the break will occur
;; and the critical section will not be entered
(semaphore-wait/enable-break lock)
(unless (eq? 'eof type)
(let ((len (- new-token-end new-token-start)))
(set! current-pos (+ len current-pos))
(sync-invalid)
(when (and should-color? (not (eq? 'white-space type)))
(set! colors (cons
(let ((color (preferences:get (string->symbol (format "syntax-coloring:~a:~a"
prefix
type))))
(sp (+ in-start-pos (sub1 new-token-start)))
(ep (+ in-start-pos (sub1 new-token-end))))
(lambda ()
(change-style color sp ep #f)))
colors)))
(insert-last! tokens (new token-tree% (length len) (data data)))
(send parens add-token data len)
(cond
((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))
(insert-last! tokens invalid-tokens)
(set! invalid-tokens-start +inf.0))
(else
(semaphore-post lock)
(break-enabled #t)
(re-tokenize in in-start-pos)))))))
(define (do-insert/delete edit-start-pos change-length)
(unless stopped?
(when (> edit-start-pos start-pos)
(set! edit-start-pos (sub1 edit-start-pos)))
(modify)
(cond
(up-to-date?
(send tokens search! (- edit-start-pos start-pos))
(let-values (((orig-token-start orig-token-end valid-tree invalid-tree)
(send tokens split)))
(send parens split-tree orig-token-start)
(set! invalid-tokens invalid-tree)
(set! tokens valid-tree)
(set! invalid-tokens-start (+ start-pos orig-token-end change-length))
(set! current-pos (+ start-pos orig-token-start))
(set! up-to-date? #f)
(colorer-callback)))
((>= edit-start-pos invalid-tokens-start)
(send invalid-tokens search! (- edit-start-pos invalid-tokens-start))
(let-values (((tok-start tok-end valid-tree invalid-tree)
(send invalid-tokens split)))
(set! invalid-tokens invalid-tree)
(set! invalid-tokens-start (+ invalid-tokens-start tok-end change-length))))
((>= edit-start-pos current-pos)
(set! invalid-tokens-start (+ change-length invalid-tokens-start)))
(else
(send tokens search! (- edit-start-pos start-pos))
(let-values (((tok-start tok-end valid-tree invalid-tree)
(send tokens split)))
(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)))))))
(define (colorer-callback)
(unless (in-edit-sequence?)
(thread-resume background-thread)
(sleep .01) ;; This is when the background thread is working.
(semaphore-wait lock)
(thread-suspend background-thread)
(semaphore-post lock)
(begin-edit-sequence #f #f)
(color)
(end-edit-sequence))
(unless up-to-date?
(queue-callback colorer-callback #f)))
;; Breaks should be disabled on entry
(define (background-colorer-entry)
(thread-suspend (current-thread))
(background-colorer))
;; Breaks should be disabled on entry
(define (background-colorer)
(let/ec restart
(parameterize ((current-exception-handler
(lambda (exn)
;; Lock is not held here because breaks are disabled
;; whenever lock is held
(break-enabled #f)
(restart))))
(break-enabled #t)
(with-handlers ((not-break-exn?
(lambda (exn)
(printf "~a~n" exn)
(break-enabled #f)
(semaphore-wait lock))))
(re-tokenize (open-input-text-editor this current-pos end-pos)
current-pos))
;; Breaks should be disabled from exit of re-tokenize
;; lock will be held
(set! up-to-date? #t)
(semaphore-post lock)
(thread-suspend (current-thread))))
(background-colorer))
(define/public (start-colorer prefix- get-token- pairs-)
(set! stopped? #f)
(reset-tokens)
(set! prefix prefix-)
(set! get-token get-token-)
(set! pairs pairs-)
(set! parens (new paren-tree% (matches pairs)))
(unless remove-prefs-callback-thunk
(set! remove-prefs-callback-thunk
(preferences:add-callback
(string->symbol (format "syntax-coloring:~a:active" prefix))
(lambda (_ on?)
(set! should-color? on?)
(cond
(on?
(reset-tokens)
(do-insert/delete start-pos 0))
(else (change-style (send (get-style-list) find-named-style "Standard")
start-pos end-pos #f)))))))
(unless background-thread
(break-enabled #f)
(set! background-thread (thread (lambda () (background-colorer-entry))))
(break-enabled #t))
(do-insert/delete start-pos 0))
(define/public (stop-colorer)
(set! stopped? #t)
(when remove-prefs-callback-thunk
(remove-prefs-callback-thunk)
(set! remove-prefs-callback-thunk #f))
(change-style (send (get-style-list) find-named-style "Standard")
start-pos end-pos #f)
(match-parens #t)
(reset-tokens)
(set! pairs null)
(set! prefix #f)
(set! get-token #f))
;; ----------------------- Match parentheses ----------------------------
(define clear-old-locations 'dummy)
(set! clear-old-locations void)
(define mismatch-color (make-object color% "PINK"))
(define (get-match-color) (preferences:get 'framework:paren-match-color))
(define (highlight start end caret-pos error?)
(let ([off (highlight-range (+ start-pos start) (+ start-pos end)
(if error? mismatch-color (get-match-color))
(and (send (icon:get-paren-highlight-bitmap) ok?)
(icon:get-paren-highlight-bitmap))
(= caret-pos (+ start-pos start)))])
(set! clear-old-locations
(let ([old clear-old-locations])
(lambda ()
(old)
(off))))))
(define in-match-parens? #f)
(define match-parens
(opt-lambda ([just-clear? #f])
(unless in-match-parens?
(set! in-match-parens? #t)
(begin-edit-sequence #f #f)
(clear-old-locations)
(set! clear-old-locations void)
(when (preferences:get 'framework:highlight-parens)
(unless just-clear?
(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)))
((start-b end-b error-b) (send parens match-backward (- here start-pos))))
(when (and start-f end-f
(not (and error-f (<= (+ start-pos error-f) current-pos) (not up-to-date?))))
(highlight start-f end-f here error-f))
(when (and start-b end-b)
(highlight start-b end-b here error-b)))))))
(end-edit-sequence)
(set! in-match-parens? #f))))
;; ------------------------- Callbacks to Override ----------------------
(rename (super-on-focus on-focus))
(define/override (on-focus on?)
(super-on-focus on?)
(match-parens (not on?)))
(rename (super-on-change on-change))
(define/override (on-change)
(modify))
(rename (super-after-edit-sequence after-edit-sequence))
(define/override (after-edit-sequence)
(super-after-edit-sequence)
(when (has-focus?)
(match-parens)))
(rename (super-after-set-position after-set-position))
(define/override (after-set-position)
(super-after-set-position)
(unless (local-edit-sequence?)
(when (has-focus?)
(match-parens)))
(modify))
(rename (super-after-change-style after-change-style))
(define/override (after-change-style a b)
(super-after-change-style a b)
(unless (get-styles-fixed)
(unless (local-edit-sequence?)
(when (has-focus?)
(match-parens))))
(modify))
(rename (super-on-set-size-constraint on-set-size-constraint))
(define/override (on-set-size-constraint)
(super-on-set-size-constraint)
(unless (local-edit-sequence?)
(when (has-focus?)
(match-parens)))
(modify))
(rename (super-after-insert after-insert))
(define/override (after-insert edit-start-pos change-length)
(do-insert/delete edit-start-pos change-length)
(super-after-insert edit-start-pos change-length))
(rename (super-after-delete after-delete))
(define/override (after-delete edit-start-pos change-length)
(do-insert/delete edit-start-pos (- change-length))
(super-after-delete edit-start-pos change-length))
(super-instantiate ())))
(define -text% (text-mixin text:keymap%))
(define -text-mode<%> (interface ()))
(define text-mode-mixin
(mixin (mode:surrogate-text<%>) (-text-mode<%>)
;; get-token takes an input port and returns 4 values:
;; A symbol in `(keyword string literal comment error identifier default)
;; Data to be kept with the token
;; The token's starting offset
;; The token's ending offset
;;
;; matches is a list of lists of matching paren types.
;; For example, '((|(| |)|) (|[| |]|))
(init-field get-token prefix (matches null))
(rename (super-on-disable-surrogate on-disable-surrogate))
(define/override (on-disable-surrogate text)
(super-on-disable-surrogate text)
(send text stop-colorer))
(rename (super-on-enable-surrogate on-enable-surrogate))
(define/override (on-enable-surrogate text)
(super-on-enable-surrogate text)
(send text start-colorer prefix get-token matches))
(super-instantiate ())))
(define text-mode% (text-mode-mixin mode:surrogate-text%))
(define (interactions-mixin %)
(class %
(rename (super-do-eval do-eval)
(super-insert-prompt insert-prompt)
(super-initialize-console initialize-console)
(super-reset-console reset-console))
(inherit reset-tokens get-prompt-position set-start-pos set-end-pos)
(define/override (do-eval start end)
(super-do-eval start end)
(set-end-pos this end))
(define/override (insert-prompt)
(super-insert-prompt)
(set-end-pos 'end)
(set-start-pos (get-prompt-position))
(reset-tokens))
(define/override (initialize-console)
(super-initialize-console)
(set-start-pos 0)
(set-end-pos 'end)
(reset-tokens))
(define/override (reset-console)
(super-reset-console)
(set-start-pos 0)
(set-end-pos 'end)
(reset-tokens))
(super-instantiate ())))
)))

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

@ -13,7 +13,8 @@
(lib "list.ss")
(lib "thread.ss")
(lib "etc.ss")
(lib "surrogate.ss"))
(lib "surrogate.ss")
(lib "scheme-lexer.ss" "syntax-color"))
(provide scheme@)
@ -30,12 +31,26 @@
[editor : framework:editor^]
[frame : framework:frame^]
[comment-box : framework:comment-box^]
[mode : framework:mode^])
[mode : framework:mode^]
[color : framework:color^]
[color-prefs : framework:color-prefs^])
(rename [-text-mode<%> text-mode<%>]
[-text<%> text<%>]
[-text% text%])
(color-prefs:add
"Scheme Color"
`((keyword ,(color-prefs:make-style-delta "Black" #f #f #f))
(string ,(color-prefs:make-style-delta "ForestGreen" #f #f #f))
(literal ,(color-prefs:make-style-delta "ForestGreen" #f #f #f))
(comment ,(color-prefs:make-style-delta "DimGray" #f #f #f))
(error ,(color-prefs:make-style-delta "Red" #f #f #f))
(identifier ,(color-prefs:make-style-delta "Navy" #f #f #f))
(other ,(color-prefs:make-style-delta "brown" #f #f #f))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; ;;
;; Sexp Snip ;;
@ -260,7 +275,6 @@
(define -text<%>
(interface ()
highlight-parens
get-limit
balance-quotes
balance-parens
@ -318,7 +332,7 @@
(send style-list find-named-style "Matching Parenthesis Style")))
(define text-mixin
(mixin (text:basic<%> mode:host-text<%>) (-text<%>)
(mixin (text:basic<%> mode:host-text<%> color:text<%>) (-text<%>)
(inherit begin-edit-sequence
delete
end-edit-sequence
@ -374,8 +388,6 @@
[define backward-cache (make-object match-cache:%)]
[define forward-cache (make-object match-cache:%)]
[define in-highlight-parens? #f]
(inherit get-styles-fixed)
(inherit has-focus? find-snip split-snip)
@ -403,96 +415,6 @@
paren-pos]
[else (loop (- semi-pos 1))]))]))))
[define clear-old-locations 'dummy]
(set! clear-old-locations void)
(define/public highlight-parens
(opt-lambda ([just-clear? #f])
(unless in-highlight-parens?
(set! in-highlight-parens? #t)
(begin-edit-sequence #f #f)
(clear-old-locations)
(set! clear-old-locations void)
(when (preferences:get 'framework:highlight-parens)
(unless just-clear?
(let* ([here (get-start-position)]
[there (get-end-position)]
[slash?
(lambda (before after)
(and (>= before 0)
(>= after 0)
(let ([text (get-text before after)])
(and (string? text)
(>= (string-length text) 1)
(char=? #\\ (string-ref text 0))))))]
[is-paren?
(lambda (f)
(lambda (char)
(ormap (lambda (x) (char=? char (string-ref (f x) 0)))
(scheme-paren:get-paren-pairs))))]
[is-left-paren? (is-paren? car)]
[is-right-paren? (is-paren? cdr)])
(when (= here there)
;; before, after : (list number number boolean)
;; numbers indicate the range to highlight
;; boolean indicates if it is an errorneous highlight
(let ([before
(cond
[(and (> here 0)
(is-right-paren? (get-character (sub1 here)))
(not (in-single-line-comment? here)))
(cond
[(slash? (- here 2) (- here 1)) #f]
[(scheme-paren:backward-match
this here (get-limit here)
backward-cache)
=>
(lambda (end-pos)
(list end-pos here #f))]
[else (list (- here 1) here #t)])]
[else #f])]
[after
(cond
[(and (is-left-paren? (get-character here))
(not (in-single-line-comment? here)))
(cond
[(slash? (- here 1) here) #f]
[(scheme-paren:forward-match
this here (last-position)
forward-cache)
=>
(lambda (end-pos)
(list here end-pos #f))]
[else (list here (+ here 1) #t)])]
[else #f])]
[handle-single
(lambda (single)
(let* ([left (first single)]
[right (second single)]
[error? (third single)]
[off (highlight-range
left
right
(if error? mismatch-color (get-match-color))
(and (send (icon:get-paren-highlight-bitmap) ok?)
(icon:get-paren-highlight-bitmap))
(= there here left))])
(set! clear-old-locations
(let ([old clear-old-locations])
(lambda ()
(old)
(off))))))])
(cond
[(and after before)
(handle-single after)
(handle-single before)]
[after (handle-single after)]
[before (handle-single before)]
[else (void)]))))))
(end-edit-sequence)
(set! in-highlight-parens? #f))))
(public get-limit balance-quotes balance-parens tabify-on-return? tabify tabify-selection
tabify-all insert-return calc-last-para
@ -1097,58 +1019,11 @@
))
(define text-mode-mixin
(mixin (mode:surrogate-text<%>) (-text-mode<%>)
(rename [super-on-focus on-focus])
(define/override (on-focus text super-call on?)
(super-on-focus text super-call on?)
(send text highlight-parens (not on?)))
(rename [super-after-change-style after-change-style])
(define/override (after-change-style text super-call start len)
(unless (send text local-edit-sequence?)
(unless (send text get-styles-fixed)
(when (send text has-focus?)
(send text highlight-parens))))
(super-after-change-style text super-call start len))
(rename [super-after-edit-sequence after-edit-sequence])
(define/override (after-edit-sequence text super-call)
(super-after-edit-sequence text super-call)
(when (send text has-focus?)
(send text highlight-parens)))
(rename [super-after-insert after-insert])
(define/override (after-insert text super-call start size)
(unless (send text local-edit-sequence?)
(when (send text has-focus?)
(send text highlight-parens)))
(super-after-insert text super-call start size))
(rename [super-after-delete after-delete])
(define/override (after-delete text super-call start size)
(unless (send text local-edit-sequence?)
(when (send text has-focus?)
(send text highlight-parens)))
(super-after-delete text super-call start size))
(rename [super-after-set-size-constraint after-set-size-constraint])
(define/override (after-set-size-constraint text super-call)
(unless (send text local-edit-sequence?)
(when (send text has-focus?)
(send text highlight-parens)))
(super-after-set-size-constraint text super-call))
(rename [super-after-set-position after-set-position])
(define/override (after-set-position text super-call)
(unless (send text local-edit-sequence?)
(when (send text has-focus?)
(send text highlight-parens)))
(super-after-set-position text super-call))
(mixin (color:text-mode<%> mode:surrogate-text<%>) (-text-mode<%>)
(rename [super-on-disable-surrogate on-disable-surrogate])
(define/override (on-disable-surrogate text)
(keymap:remove-chained-keymap text keymap)
(send text highlight-parens #t)
(super-on-disable-surrogate text))
(rename [super-on-enable-surrogate on-enable-surrogate])
@ -1156,9 +1031,6 @@
(send text begin-edit-sequence)
(super-on-enable-surrogate text)
(send (send text get-keymap) chain-to-keymap keymap #t)
(unless (send text local-edit-sequence?)
(when (send text has-focus?)
(send text highlight-parens)))
;; I don't know about these editor flag settings.
;; maybe they belong in drscheme?
@ -1174,8 +1046,23 @@
(send text set-styles-fixed #t)
(send text end-edit-sequence))
(super-instantiate ())))
(super-new (get-token scheme-lexer-wrapper)
(prefix "Scheme Color")
(matches '((|(| |)|)
(|[| |]|)
(|{| |}|))))))
(define (scheme-lexer-wrapper in)
(let-values (((type lex start end) (scheme-lexer in)))
(cond
((and (eq? type 'identifier)
(hash-table-get (preferences:get 'framework:tabify)
(string->symbol lex)
(lambda () #f)))
(values 'keyword lex start end))
(else
(values type lex start end)))))
(define set-mode-mixin
(mixin (-text<%> mode:host-text<%>) ()
(super-new)
@ -1185,9 +1072,9 @@
(define -text% (set-mode-mixin
(text-mixin
(mode:host-text-mixin
text:keymap%))))
color:text%))))
(define text-mode% (text-mode-mixin mode:surrogate-text%))
(define text-mode% (text-mode-mixin color:text-mode%))
;; ;;

31
collects/framework/private/sig.ss
View File

@ -65,6 +65,12 @@
framework:scheme-paren^
framework:scheme-paren-class^
framework:scheme-paren-fun^
framework:color^
framework:color-class^
framework:color-fun^
framework:color-prefs^
framework:color-prefs-class^
framework:color-prefs-fun^
framework:scheme^
framework:scheme-class^
framework:scheme-fun^
@ -497,6 +503,31 @@
((open framework:scheme-paren-class^)
(open framework:scheme-paren-fun^)))
(define-signature framework:color-class^
(text<%>
text-mixin
text%
text-mode<%>
text-mode-mixin
text-mode%
interactions-mixin))
(define-signature framework:color-fun^
())
(define-signature framework:color^
((open framework:color-class^)
(open framework:color-fun^)))
(define-signature framework:color-prefs-class^
(make-style-delta add))
(define-signature framework:color-prefs-fun^
())
(define-signature framework:color-prefs^
((open framework:color-prefs-class^)
(open framework:color-prefs-fun^)))
(define-signature framework:scheme-class^
(text<%>
text-mixin