The initial import of on-the-fly lexical coloring and parenthesis matching.
original commit: 12f2192322a8544642529bccc197214d02316689
This commit is contained in:
parent
88034d298b
commit
8ba1181bd5
245
collects/framework/private/color-prefs.ss
Normal file
245
collects/framework/private/color-prefs.ss
Normal 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
440
collects/framework/private/color.ss
Normal 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 ())))
|
||||||
|
)))
|
||||||
|
|
|
@ -13,7 +13,8 @@
|
||||||
(lib "list.ss")
|
(lib "list.ss")
|
||||||
(lib "thread.ss")
|
(lib "thread.ss")
|
||||||
(lib "etc.ss")
|
(lib "etc.ss")
|
||||||
(lib "surrogate.ss"))
|
(lib "surrogate.ss")
|
||||||
|
(lib "scheme-lexer.ss" "syntax-color"))
|
||||||
|
|
||||||
(provide scheme@)
|
(provide scheme@)
|
||||||
|
|
||||||
|
@ -30,12 +31,26 @@
|
||||||
[editor : framework:editor^]
|
[editor : framework:editor^]
|
||||||
[frame : framework:frame^]
|
[frame : framework:frame^]
|
||||||
[comment-box : framework:comment-box^]
|
[comment-box : framework:comment-box^]
|
||||||
[mode : framework:mode^])
|
[mode : framework:mode^]
|
||||||
|
[color : framework:color^]
|
||||||
|
[color-prefs : framework:color-prefs^])
|
||||||
|
|
||||||
(rename [-text-mode<%> text-mode<%>]
|
(rename [-text-mode<%> text-mode<%>]
|
||||||
[-text<%> text<%>]
|
[-text<%> text<%>]
|
||||||
[-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 ;;
|
;; Sexp Snip ;;
|
||||||
|
@ -260,7 +275,6 @@
|
||||||
|
|
||||||
(define -text<%>
|
(define -text<%>
|
||||||
(interface ()
|
(interface ()
|
||||||
highlight-parens
|
|
||||||
get-limit
|
get-limit
|
||||||
balance-quotes
|
balance-quotes
|
||||||
balance-parens
|
balance-parens
|
||||||
|
@ -318,7 +332,7 @@
|
||||||
(send style-list find-named-style "Matching Parenthesis Style")))
|
(send style-list find-named-style "Matching Parenthesis Style")))
|
||||||
|
|
||||||
(define text-mixin
|
(define text-mixin
|
||||||
(mixin (text:basic<%> mode:host-text<%>) (-text<%>)
|
(mixin (text:basic<%> mode:host-text<%> color:text<%>) (-text<%>)
|
||||||
(inherit begin-edit-sequence
|
(inherit begin-edit-sequence
|
||||||
delete
|
delete
|
||||||
end-edit-sequence
|
end-edit-sequence
|
||||||
|
@ -374,8 +388,6 @@
|
||||||
[define backward-cache (make-object match-cache:%)]
|
[define backward-cache (make-object match-cache:%)]
|
||||||
[define forward-cache (make-object match-cache:%)]
|
[define forward-cache (make-object match-cache:%)]
|
||||||
|
|
||||||
[define in-highlight-parens? #f]
|
|
||||||
|
|
||||||
(inherit get-styles-fixed)
|
(inherit get-styles-fixed)
|
||||||
(inherit has-focus? find-snip split-snip)
|
(inherit has-focus? find-snip split-snip)
|
||||||
|
|
||||||
|
@ -403,96 +415,6 @@
|
||||||
paren-pos]
|
paren-pos]
|
||||||
[else (loop (- semi-pos 1))]))]))))
|
[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
|
(public get-limit balance-quotes balance-parens tabify-on-return? tabify tabify-selection
|
||||||
tabify-all insert-return calc-last-para
|
tabify-all insert-return calc-last-para
|
||||||
|
@ -1097,58 +1019,11 @@
|
||||||
))
|
))
|
||||||
|
|
||||||
(define text-mode-mixin
|
(define text-mode-mixin
|
||||||
(mixin (mode:surrogate-text<%>) (-text-mode<%>)
|
(mixin (color:text-mode<%> 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))
|
|
||||||
|
|
||||||
(rename [super-on-disable-surrogate on-disable-surrogate])
|
(rename [super-on-disable-surrogate on-disable-surrogate])
|
||||||
(define/override (on-disable-surrogate text)
|
(define/override (on-disable-surrogate text)
|
||||||
(keymap:remove-chained-keymap text keymap)
|
(keymap:remove-chained-keymap text keymap)
|
||||||
(send text highlight-parens #t)
|
|
||||||
(super-on-disable-surrogate text))
|
(super-on-disable-surrogate text))
|
||||||
|
|
||||||
(rename [super-on-enable-surrogate on-enable-surrogate])
|
(rename [super-on-enable-surrogate on-enable-surrogate])
|
||||||
|
@ -1156,9 +1031,6 @@
|
||||||
(send text begin-edit-sequence)
|
(send text begin-edit-sequence)
|
||||||
(super-on-enable-surrogate text)
|
(super-on-enable-surrogate text)
|
||||||
(send (send text get-keymap) chain-to-keymap keymap #t)
|
(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.
|
;; I don't know about these editor flag settings.
|
||||||
;; maybe they belong in drscheme?
|
;; maybe they belong in drscheme?
|
||||||
|
@ -1174,7 +1046,22 @@
|
||||||
(send text set-styles-fixed #t)
|
(send text set-styles-fixed #t)
|
||||||
(send text end-edit-sequence))
|
(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
|
(define set-mode-mixin
|
||||||
(mixin (-text<%> mode:host-text<%>) ()
|
(mixin (-text<%> mode:host-text<%>) ()
|
||||||
|
@ -1185,9 +1072,9 @@
|
||||||
(define -text% (set-mode-mixin
|
(define -text% (set-mode-mixin
|
||||||
(text-mixin
|
(text-mixin
|
||||||
(mode:host-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%))
|
||||||
|
|
||||||
|
|
||||||
;; ;;
|
;; ;;
|
||||||
|
|
|
@ -65,6 +65,12 @@
|
||||||
framework:scheme-paren^
|
framework:scheme-paren^
|
||||||
framework:scheme-paren-class^
|
framework:scheme-paren-class^
|
||||||
framework:scheme-paren-fun^
|
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^
|
||||||
framework:scheme-class^
|
framework:scheme-class^
|
||||||
framework:scheme-fun^
|
framework:scheme-fun^
|
||||||
|
@ -497,6 +503,31 @@
|
||||||
((open framework:scheme-paren-class^)
|
((open framework:scheme-paren-class^)
|
||||||
(open framework:scheme-paren-fun^)))
|
(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^
|
(define-signature framework:scheme-class^
|
||||||
(text<%>
|
(text<%>
|
||||||
text-mixin
|
text-mixin
|
||||||
|
|
Loading…
Reference in New Issue
Block a user