95 lines
3.5 KiB
Racket
95 lines
3.5 KiB
Racket
#lang scheme/base
|
|
(require scheme/unit
|
|
scheme/class
|
|
scheme/bool
|
|
mred
|
|
(only-in mzlib/etc identity)
|
|
scheme/list
|
|
drscheme/tool
|
|
string-constants)
|
|
|
|
(provide tool@)
|
|
|
|
(define tool@
|
|
(unit
|
|
(import drscheme:tool^)
|
|
(export drscheme:tool-exports^)
|
|
|
|
(define big-frtime-language%
|
|
(class* object% (drscheme:language:simple-module-based-language<%>)
|
|
(define/public (get-language-numbers)
|
|
'(1000 -400))
|
|
(define/public (get-language-position)
|
|
(list (string-constant experimental-languages) "FrTime"))
|
|
(define/public (get-module)
|
|
'frtime/frtime-big)
|
|
(define/public (get-one-line-summary)
|
|
"Language for functional programming of event-driven systems")
|
|
(define/public (get-language-url) #f)
|
|
(define/public (get-reader)
|
|
(lambda (name port)
|
|
(let ([v (read-syntax name port)])
|
|
(if (eof-object? v)
|
|
v
|
|
(namespace-syntax-introduce v)))))
|
|
(super-instantiate ())))
|
|
|
|
(define (weak-member obj lis)
|
|
(let ([cmp (lambda (v) (eq? v obj))])
|
|
(let loop ([lis lis])
|
|
(and (cons? lis)
|
|
(or
|
|
(cond
|
|
[(weak-box-value (first lis)) => cmp]
|
|
[else false])
|
|
(loop (rest lis)))))))
|
|
|
|
(define (watch watch-list value super-render-fun)
|
|
(foldl
|
|
(lambda (wb acc)
|
|
(cond
|
|
[(weak-box-value wb)
|
|
=> (lambda (f) (f acc super-render-fun))]
|
|
[else acc]))
|
|
value
|
|
watch-list))
|
|
|
|
(define (make-frtime-language base)
|
|
(class (drscheme:language:module-based-language->language-mixin
|
|
(drscheme:language:simple-module-based-language->module-based-language-mixin
|
|
base))
|
|
(field (watch-list empty))
|
|
(inherit get-language-position)
|
|
(define/override (get-language-name)
|
|
"FrTime")
|
|
(define/override (on-execute settings run-in-user-thread)
|
|
(let ([drs-eventspace (current-eventspace)])
|
|
(super on-execute settings run-in-user-thread)
|
|
(run-in-user-thread
|
|
(lambda ()
|
|
(let ([new-watch (namespace-variable-value 'watch)]
|
|
[set-evspc (namespace-variable-value 'set-eventspace)])
|
|
(set-evspc drs-eventspace)
|
|
(set! watch-list
|
|
((if (weak-member new-watch watch-list)
|
|
identity
|
|
(lambda (r) (cons (make-weak-box new-watch) r)))
|
|
(filter weak-box-value watch-list))))))))
|
|
|
|
;; pass (lambda (v) (super render-value(/format) v settings width port))
|
|
;; to watcher
|
|
(override render-value/format render-value)
|
|
(define (render-value/format value settings port width)
|
|
(super render-value/format (watch watch-list value (lambda (v prt) (render-value/format v settings prt width)))
|
|
settings port width))
|
|
(define (render-value value settings port)
|
|
(super render-value (watch watch-list value (lambda (v prt) (render-value settings prt)))
|
|
settings port))
|
|
(define/override (use-namespace-require/copy?) #t)
|
|
(super-instantiate ())))
|
|
|
|
(define (phase1) (void))
|
|
(define (phase2)
|
|
(drscheme:language-configuration:add-language
|
|
(make-object ((drscheme:language:get-default-mixin) (make-frtime-language big-frtime-language%)))))))
|