558 lines
20 KiB
Racket
558 lines
20 KiB
Racket
(module lang-core mzscheme
|
|
(require-for-syntax frtime/struct mzlib/list)
|
|
(require mzlib/list
|
|
frtime/core/frp
|
|
(only srfi/43/vector-lib vector-any)
|
|
(only frtime/lang-ext lift new-cell switch ==> changes deep-value-now)
|
|
(only mzlib/etc build-vector rec build-list opt-lambda identity))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; Fundamental Macros ;;
|
|
;;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
(define-syntax frp:letrec
|
|
(syntax-rules ()
|
|
[(_ ([id val] ...) expr ...)
|
|
(let ([id (new-cell)] ...)
|
|
(let ([tmp val])
|
|
(when (or (signal? tmp) (any-nested-reactivity? tmp))
|
|
(set-cell! id tmp))
|
|
(set! id tmp))
|
|
...
|
|
expr ...)]))
|
|
|
|
(define (->boolean x)
|
|
(if x #t #f))
|
|
|
|
(define (frp:->boolean x)
|
|
(lift #t ->boolean x))
|
|
|
|
(define-syntax frp:if
|
|
(syntax-rules ()
|
|
[(_ test-exp then-exp)
|
|
(frp:if test-exp then-exp (void))]
|
|
[(_ test-exp then-exp else-exp)
|
|
(frp:if test-exp then-exp else-exp undefined)]
|
|
[(_ test-exp then-exp else-exp undef-exp)
|
|
(super-lift
|
|
(lambda (b)
|
|
(cond
|
|
[(undefined? b) undef-exp]
|
|
[b then-exp]
|
|
[else else-exp]))
|
|
(frp:->boolean test-exp))]))
|
|
|
|
(define (frp:copy-list lst)
|
|
(frp:if (null? lst)
|
|
()
|
|
(frp:cons (frp:car lst) (frp:copy-list (frp:cdr lst)))))
|
|
|
|
(define-syntax frp:let-values
|
|
(syntax-rules ()
|
|
[(_ ([vars expr] ...) body0 body1 ...)
|
|
(let-values ([vars (split-multiple expr)] ...)
|
|
body0 body1 ...)]))
|
|
|
|
(define-for-syntax (get-rest-arg arglist-stx)
|
|
(syntax-case arglist-stx ()
|
|
[var
|
|
(identifier? arglist-stx)
|
|
arglist-stx]
|
|
[(var ...)
|
|
#f]
|
|
[(var . others)
|
|
(get-rest-arg #'others)]))
|
|
|
|
(define-for-syntax (translate-clause stx)
|
|
(syntax-case stx ()
|
|
[(bindings body0 body1 ...)
|
|
(let ([the-rest-arg (get-rest-arg #'bindings)])
|
|
(if the-rest-arg
|
|
#`(bindings
|
|
(let ([#,the-rest-arg (frp:copy-list #,the-rest-arg)])
|
|
body0 body1 ...))
|
|
#'(bindings body0 body1 ...)))]))
|
|
|
|
(define-syntax (frp:lambda stx)
|
|
(syntax-case stx ()
|
|
[(_ bindings body0 body1 ...)
|
|
(with-syntax ([new-clause (translate-clause #'(bindings body0 body1 ...))])
|
|
#'(lambda . new-clause))]))
|
|
|
|
(define-syntax (frp:case-lambda stx)
|
|
(syntax-case stx ()
|
|
[(_ clause ...)
|
|
(with-syntax ([(new-clause ...)
|
|
(map translate-clause (syntax->list #'(clause ...)))])
|
|
#'(case-lambda
|
|
new-clause ...))]))
|
|
|
|
(define any-nested-reactivity?
|
|
(opt-lambda (obj [mem empty])
|
|
(with-handlers ((exn:fail?
|
|
(lambda (e)
|
|
(fprintf
|
|
(current-error-port)
|
|
"you've encountered a bug in frtime. please send a report to the Racket mailing list.\nexn: ~a\n"
|
|
e) #f)))
|
|
(cond
|
|
[(memq obj mem) #f]
|
|
[(behavior? obj) #t]
|
|
[(cons? obj)
|
|
(let ([mem (cons obj mem)])
|
|
(or (any-nested-reactivity? (car obj) mem)
|
|
(any-nested-reactivity? (cdr obj) mem)))]
|
|
[(struct? obj)
|
|
(let*-values ([(info skipped) (struct-info obj)]
|
|
[(name init-k auto-k acc mut immut sup skipped?) (struct-type-info info)]
|
|
[(ctor) (struct-type-make-constructor info)])
|
|
(ormap (lambda (i) (any-nested-reactivity? (acc obj i) (cons obj mem)))
|
|
(build-list init-k (lambda (x) x))))]
|
|
[(vector? obj) (vector-any (lambda (o) (any-nested-reactivity? o (cons obj mem))) obj)]
|
|
[else #f]))))
|
|
|
|
(define (deep-value-now/update-deps obj deps table)
|
|
(cond
|
|
[(assq obj table) => second]
|
|
[(behavior? obj)
|
|
(case (hash-table-get deps obj 'absent)
|
|
[(absent) (hash-table-put! deps obj 'new)]
|
|
[(old) (hash-table-put! deps obj 'alive)]
|
|
[(new) (void)])
|
|
(deep-value-now/update-deps (signal-value obj) deps
|
|
(cons (list obj (signal-value obj)) table))]
|
|
[(cons? obj)
|
|
(let* ([result (cons #f #f)]
|
|
[new-table (cons (list obj result) table)]
|
|
[car-val (deep-value-now/update-deps (car obj) deps new-table)]
|
|
[cdr-val (deep-value-now/update-deps (cdr obj) deps new-table)])
|
|
(if (and (eq? car-val (car obj))
|
|
(eq? cdr-val (cdr obj)))
|
|
obj
|
|
(cons car-val cdr-val)))]
|
|
; won't work in the presence of super structs or immutable fields
|
|
[(struct? obj)
|
|
(let*-values ([(info skipped) (struct-info obj)]
|
|
[(name init-k auto-k acc mut! immut sup skipped?) (struct-type-info info)]
|
|
[(ctor) (struct-type-make-constructor info)]
|
|
[(indices) (build-list init-k identity)]
|
|
[(result) (apply ctor (build-list init-k (lambda (i) #f)))]
|
|
[(new-table) (cons (list obj result) table)]
|
|
[(elts) (build-list init-k (lambda (i) (deep-value-now/update-deps (acc obj i) deps new-table)))])
|
|
(if (andmap (lambda (i e) (eq? (acc obj i) e)) indices elts)
|
|
obj
|
|
(begin
|
|
(for-each (lambda (i e) (mut! result i e)) indices elts)
|
|
result)))]
|
|
[(vector? obj)
|
|
(let* ([len (vector-length obj)]
|
|
[indices (build-list len identity)]
|
|
[result (build-vector len (lambda (_) #f))]
|
|
[new-table (cons (list obj result) table)]
|
|
[elts (build-list len (lambda (i) (deep-value-now/update-deps (vector-ref obj i) deps new-table)))])
|
|
(if (andmap (lambda (i e) (eq? (vector-ref obj i) e)) indices elts)
|
|
obj
|
|
(begin
|
|
(for-each (lambda (i e) (vector-set! result i e)) indices elts)
|
|
result)))]
|
|
[else obj]))
|
|
|
|
(define (public-dvn obj)
|
|
(do-in-manager-after
|
|
(deep-value-now obj empty)))
|
|
|
|
(define any-spinal-reactivity?
|
|
(opt-lambda (lst [mem empty])
|
|
(cond
|
|
[(memq lst mem) #f]
|
|
[(behavior? lst) #t]
|
|
[(cons? lst) (any-spinal-reactivity? (cdr lst) (cons lst mem))]
|
|
[else #f])))
|
|
|
|
(define (deep-cdr-value-now/update-deps obj deps table)
|
|
(cond
|
|
[(behavior? obj)
|
|
(case (hash-table-get deps obj 'absent)
|
|
[(absent) (hash-table-put! deps obj 'new)]
|
|
[(old) (hash-table-put! deps obj 'alive)]
|
|
[(new) (void)])
|
|
(deep-cdr-value-now/update-deps (signal-value obj) deps table)]
|
|
[(cons? obj)
|
|
(let* ([cdr-val (deep-cdr-value-now/update-deps (cdr obj) deps table)])
|
|
(cons (car obj) cdr-val))]
|
|
[else obj]))
|
|
|
|
(define (raise-list-for-apply obj)
|
|
(if (any-spinal-reactivity? obj)
|
|
(let ([rtn (proc->signal void)])
|
|
(set-signal-thunk!
|
|
rtn
|
|
(let ([deps (make-hash-table)])
|
|
(lambda ()
|
|
(begin0
|
|
(deep-cdr-value-now/update-deps obj deps empty)
|
|
(hash-table-for-each
|
|
deps
|
|
(lambda (k v)
|
|
(case v
|
|
[(new) (hash-table-put! deps k 'old)
|
|
(register rtn k)
|
|
(do-in-manager
|
|
(iq-enqueue rtn))]
|
|
[(alive) (hash-table-put! deps k 'old)]
|
|
[(old) (hash-table-remove! deps k)
|
|
(unregister rtn k)])))))))
|
|
(do-in-manager
|
|
(iq-enqueue rtn))
|
|
rtn)
|
|
obj))
|
|
|
|
(define (raise-reactivity obj)
|
|
(let ([rtn (proc->signal void)])
|
|
(set-signal-thunk!
|
|
rtn
|
|
(let ([deps (make-hash-table)])
|
|
(lambda ()
|
|
(begin0
|
|
(deep-value-now/update-deps obj deps empty)
|
|
(hash-table-for-each
|
|
deps
|
|
(lambda (k v)
|
|
(case v
|
|
[(new) (hash-table-put! deps k 'old)
|
|
(register rtn k)]
|
|
[(alive) (hash-table-put! deps k 'old)]
|
|
[(old) (hash-table-remove! deps k)
|
|
(unregister rtn k)])))))))
|
|
(do-in-manager
|
|
(iq-enqueue rtn))
|
|
rtn))
|
|
|
|
(define (compound-lift proc)
|
|
(let ([rtn (proc->signal void)])
|
|
(set-signal-thunk!
|
|
rtn
|
|
(let ([deps (make-hash-table)])
|
|
(lambda ()
|
|
(begin0
|
|
(let/ec esc
|
|
(begin0
|
|
(proc (lambda (obj)
|
|
(if (behavior? obj)
|
|
(begin
|
|
(case (hash-table-get deps obj 'absent)
|
|
[(absent) (hash-table-put! deps obj 'new)
|
|
(let ([o-depth (signal-depth rtn)])
|
|
(register rtn obj)
|
|
(when (> (signal-depth rtn) o-depth)
|
|
(iq-enqueue rtn)
|
|
(esc #f)))]
|
|
[(old) (hash-table-put! deps obj 'alive)]
|
|
[(new) (void)])
|
|
(value-now obj))
|
|
obj)));)
|
|
(hash-table-for-each
|
|
deps
|
|
(lambda (k v)
|
|
(case v
|
|
[(new alive) (hash-table-put! deps k 'old)]
|
|
[(old) (hash-table-remove! deps k)
|
|
(unregister rtn k)])))))))))
|
|
(iq-enqueue rtn)
|
|
rtn))
|
|
|
|
;;;;;;;;;;;;;;;;
|
|
;; Structures ;;
|
|
;;;;;;;;;;;;;;;;
|
|
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; CONS
|
|
|
|
|
|
(define frp:cons cons)
|
|
|
|
(define (make-accessor acc)
|
|
(lambda (v)
|
|
(let loop ([v v])
|
|
(cond
|
|
[(signal:compound? v) (acc (signal:compound-content v))]
|
|
[(signal? v) (super-lift acc v)]
|
|
[(signal:switching? v) (super-lift
|
|
(lambda (_)
|
|
(loop (unbox (signal:switching-current v))))
|
|
(signal:switching-trigger v))]
|
|
[(undefined? v) undefined]
|
|
[else (acc v)]))))
|
|
|
|
(define frp:car
|
|
(make-accessor car))
|
|
|
|
(define frp:cdr
|
|
(make-accessor cdr))
|
|
|
|
(define frp:pair? (lambda (arg) (if (signal:compound? arg)
|
|
(pair? (signal:compound-content arg))
|
|
(lift #t pair? arg))))
|
|
|
|
(define (frp:null? arg)
|
|
(if (signal:compound? arg)
|
|
#f
|
|
(lift #t null? arg)))
|
|
|
|
(define frp:empty? frp:null?)
|
|
|
|
(define (list-match lst cf ef)
|
|
(super-lift
|
|
(lambda (lst)
|
|
(cond
|
|
[(undefined? lst) undefined]
|
|
[(pair? lst) (cf (first lst) (rest lst))]
|
|
[(empty? lst) (ef)]
|
|
[else (error "list-match: expected a list, got ~a" lst)]))
|
|
lst))
|
|
|
|
(define frp:append
|
|
(case-lambda
|
|
[() ()]
|
|
[(lst) lst]
|
|
[(lst1 lst2 . lsts)
|
|
(list-match lst1
|
|
(lambda (f r) (cons f (apply frp:append r lst2 lsts)))
|
|
(lambda () (apply frp:append lst2 lsts)))]))
|
|
|
|
(define frp:list list)
|
|
|
|
(define frp:list*
|
|
(lambda elts
|
|
(frp:if (frp:empty? elts)
|
|
'()
|
|
(frp:if (frp:empty? (frp:cdr elts))
|
|
(frp:car elts)
|
|
(frp:cons (frp:car elts)
|
|
(apply frp:list* (frp:cdr elts)))))))
|
|
|
|
(define (frp:list? itm)
|
|
(if (signal:compound? itm)
|
|
(let ([ctnt (signal:compound-content itm)])
|
|
(if (cons? ctnt)
|
|
(frp:list? (cdr ctnt))
|
|
#f))
|
|
(if (signal? itm)
|
|
(frp:if (lift #t cons? itm)
|
|
(frp:list? (frp:cdr itm))
|
|
(frp:null? itm))
|
|
(or (null? itm)
|
|
(and (cons? itm) (frp:list? (cdr itm)))))))
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; Vector
|
|
|
|
|
|
(define frp:vector vector)
|
|
|
|
(define (frp:vector-ref v i)
|
|
(cond
|
|
[(behavior? v) (super-lift (lambda (v) (frp:vector-ref v i)) v)]
|
|
[else (lift #t vector-ref v i)]))
|
|
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; make-struct-type + define-struct Macros
|
|
|
|
|
|
(define (frp:make-struct-type name-symbol super-struct-type init-field-k auto-field-k . args)
|
|
(let-values ([(desc ctor pred acc mut)
|
|
(apply make-struct-type name-symbol super-struct-type init-field-k auto-field-k
|
|
args)])
|
|
(values
|
|
desc
|
|
ctor
|
|
(lambda (v) (if (signal:compound? v)
|
|
(pred (value-now/no-copy v))
|
|
(lift #t pred v)))
|
|
acc
|
|
mut)))
|
|
|
|
(define (frp:make-struct-field-accessor acc i sym)
|
|
(make-accessor (make-struct-field-accessor acc i sym)))
|
|
|
|
; FORBIDS MUTATION
|
|
(define (frp:make-struct-field-mutator acc i sym)
|
|
(lambda (s _)
|
|
(error "MUTATION NOT ALLOWED IN FrTime STRUCTURES")))
|
|
|
|
(define-syntax (frp:define-struct stx)
|
|
(syntax-case stx ()
|
|
[(_ (s t) (field ...) insp)
|
|
#;(define-struct (s t) (field ...) (make-inspector insp))
|
|
(let ([field-names (syntax->list #'(field ...))]
|
|
[super-for-gen (if (syntax-e #'t)
|
|
(string->symbol
|
|
(format "struct:~a" (syntax-e #'t)))
|
|
#f)]
|
|
[super-for-exp (if (syntax-e #'t)
|
|
#'t
|
|
#t)])
|
|
#`(begin
|
|
(define-values #,(build-struct-names #'s field-names #f #f stx)
|
|
(parameterize ([current-inspector (make-inspector insp)])
|
|
#,(build-struct-generation #'s field-names #f #f super-for-gen)))
|
|
(define-syntax s
|
|
#,(build-struct-expand-info #'s field-names #f #f super-for-exp
|
|
empty empty))))]
|
|
[(_ (s t) (field ...))
|
|
#'(frp:define-struct (s t) (field ...) (current-inspector))]
|
|
[(_ s (field ...) insp)
|
|
#'(frp:define-struct (s #f) (field ...) insp)]
|
|
[(_ s (field ...))
|
|
#'(frp:define-struct (s #f) (field ...) (current-inspector))]))
|
|
|
|
(define (find pred lst)
|
|
(cond
|
|
[(empty? lst) #f]
|
|
[(pred (first lst)) (first lst)]
|
|
[else (find pred (rest lst))]))
|
|
|
|
|
|
(define (ensure-no-signal-args val name)
|
|
(if (procedure? val)
|
|
(lambda args
|
|
(cond
|
|
[(find signal? args)
|
|
=>
|
|
(lambda (v)
|
|
(raise-type-error name "non-signal"
|
|
(format "#<signal: ~a>" (signal-value v))))]
|
|
[else (apply val args)]))))
|
|
|
|
|
|
;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; Provide & Require ;;
|
|
;;;;;;;;;;;;;;;;;;;;;;;
|
|
|
|
|
|
(define-syntax (frp:provide stx)
|
|
(syntax-case stx ()
|
|
[(_ . clauses)
|
|
(foldl
|
|
(lambda (c prev)
|
|
(syntax-case prev ()
|
|
[(begin clause ...)
|
|
(syntax-case c (lifted lifted:nonstrict)
|
|
[(lifted . ids)
|
|
(with-syntax ([(fun-name ...) (syntax ids)]
|
|
[(tmp-name ...)
|
|
(map (lambda (id)
|
|
(datum->syntax-object stx (syntax-object->datum id)))
|
|
(generate-temporaries (syntax ids)))])
|
|
(syntax
|
|
(begin
|
|
clause ...
|
|
(define (tmp-name . args)
|
|
(apply lift #t fun-name args))
|
|
...
|
|
(provide (rename tmp-name fun-name) ...))))]
|
|
[(lifted:nonstrict . ids)
|
|
(with-syntax ([(fun-name ...) (syntax ids)]
|
|
[(tmp-name ...)
|
|
(map (lambda (id)
|
|
(datum->syntax-object stx (syntax-object->datum id)))
|
|
(generate-temporaries (syntax ids)))])
|
|
(syntax
|
|
(begin
|
|
clause ...
|
|
(define (tmp-name . args)
|
|
(apply lift #f fun-name args))
|
|
...
|
|
(provide (rename tmp-name fun-name) ...))))]
|
|
[provide-spec
|
|
(syntax (begin clause ... (provide provide-spec)))])]))
|
|
(syntax (begin))
|
|
(syntax->list (syntax clauses)))]))
|
|
|
|
(define-syntax (frp:require stx)
|
|
(define (generate-temporaries/loc st ids)
|
|
(map (lambda (id)
|
|
(datum->syntax-object stx (syntax-object->datum id)))
|
|
(generate-temporaries ids)))
|
|
(syntax-case stx ()
|
|
[(_ . clauses)
|
|
(foldl
|
|
(lambda (c prev)
|
|
(syntax-case prev ()
|
|
[(begin clause ...)
|
|
(syntax-case c (lifted lifted:nonstrict as-is:unchecked as-is)
|
|
[(lifted:nonstrict module . ids)
|
|
(with-syntax ([(fun-name ...) #'ids]
|
|
[(tmp-name ...) (generate-temporaries/loc stx #'ids)])
|
|
#'(begin
|
|
clause ...
|
|
(require (rename module tmp-name fun-name) ...)
|
|
(define (fun-name . args)
|
|
(apply lift #f tmp-name args))
|
|
...))]
|
|
[(lifted module . ids)
|
|
(with-syntax ([(fun-name ...) (syntax ids)]
|
|
[(tmp-name ...) (generate-temporaries/loc stx #'ids)])
|
|
#'(begin
|
|
clause ...
|
|
(require (rename module tmp-name fun-name) ...)
|
|
(define (fun-name . args)
|
|
(apply lift #t tmp-name args))
|
|
...))]
|
|
[(as-is:unchecked module id ...)
|
|
(syntax (begin clause ... (require (rename module id id) ...)))]
|
|
[(as-is module . ids)
|
|
(with-syntax ([(fun-name ...) (syntax ids)]
|
|
[(tmp-name ...) (generate-temporaries/loc stx #'ids)])
|
|
#'(begin
|
|
clause ...
|
|
(require (rename module tmp-name fun-name) ...)
|
|
(define fun-name (ensure-no-signal-args tmp-name 'fun-name))
|
|
...))]
|
|
[require-spec
|
|
#'(begin clause ... (require require-spec))])]))
|
|
#'(begin)
|
|
(syntax->list #'clauses))]))
|
|
|
|
|
|
|
|
|
|
(provide module
|
|
#%app
|
|
#%top
|
|
#%datum
|
|
#%plain-module-begin
|
|
#%module-begin
|
|
#%top-interaction
|
|
raise-reactivity
|
|
raise-list-for-apply
|
|
(rename public-dvn deep-value-now)
|
|
any-nested-reactivity?
|
|
compound-lift
|
|
list-match
|
|
(rename frp:if if)
|
|
(rename frp:lambda lambda)
|
|
(rename frp:case-lambda case-lambda)
|
|
(rename frp:letrec letrec)
|
|
(rename frp:cons cons)
|
|
(rename frp:car car)
|
|
(rename frp:cdr cdr)
|
|
(rename frp:list list)
|
|
(rename frp:list? list?)
|
|
(rename frp:list* list*)
|
|
(rename frp:null? null?)
|
|
(rename frp:pair? pair?)
|
|
(rename frp:append append)
|
|
(rename frp:vector vector)
|
|
(rename frp:vector-ref vector-ref)
|
|
(rename frp:make-struct-type make-struct-type)
|
|
(rename frp:make-struct-field-accessor make-struct-field-accessor)
|
|
(rename frp:make-struct-field-mutator make-struct-field-mutator)
|
|
(rename frp:define-struct define-struct)
|
|
(rename frp:provide provide)
|
|
(rename frp:require require)
|
|
frp:copy-list
|
|
frp:->boolean))
|