diff options
| author | Hugo Hörnquist <hugo@lysator.liu.se> | 2023-09-13 01:33:53 +0200 |
|---|---|---|
| committer | Hugo Hörnquist <hugo@lysator.liu.se> | 2023-09-13 01:33:53 +0200 |
| commit | 813f242dae1a890d80507c59369b8b731012e683 (patch) | |
| tree | be339fa1d0f1229aa04dad6dd22ace158b049d45 | |
| parent | Minor cleanup of test stats from makefile. (diff) | |
| download | calp-813f242dae1a890d80507c59369b8b731012e683.tar.gz calp-813f242dae1a890d80507c59369b8b731012e683.tar.xz | |
Rewrote `with-replaced-properties`.
The old version built on the old stateful components, while the new
version is stateless. This also clearly shows the benefits of stateless
components.
| -rw-r--r-- | module/vcomponent/util/control.scm | 38 |
1 files changed, 9 insertions, 29 deletions
diff --git a/module/vcomponent/util/control.scm b/module/vcomponent/util/control.scm index 19a6fa18..9ef93c30 100644 --- a/module/vcomponent/util/control.scm +++ b/module/vcomponent/util/control.scm @@ -1,37 +1,17 @@ (define-module (vcomponent util control) - :use-module (hnh util) - :use-module (vcomponent) + :use-module ((vcomponent) :select (prop)) + :use-module ((srfi srfi-1) :select (fold)) :export (with-replaced-properties)) - -(eval-when (expand load) ; No idea why I must have load here. - (define href (make-procedure-with-setter hash-ref hash-set!)) - - (define (set-temp-values! table component kvs) - (for-each (lambda (kv) - (let ((key (car kv)) - (val (cadr kv))) - (when (prop component key) - (set! (href table key) (prop component key)) - (set! (prop component key) val)))) - kvs)) - - (define (restore-values! table component keys) - (for-each (lambda (key) - (and=> (href table key) - (lambda (val) - (set! (prop component key) val)))) - keys))) - -;; TODO what is this even used for? (define-syntax with-replaced-properties (syntax-rules () - [(G_ (component (key val) ...) + [(_ (component (key val) ...) body ...) - (let ((htable (make-hash-table 10))) - (dynamic-wind - (lambda () (set-temp-values! htable component (quote ((key val) ...)))) ; In guard - (lambda () body ...) - (lambda () (restore-values! htable component (quote (key ...))))))])) ; Out guard + (let ((component + (fold (lambda (pair component) + (prop component (car pair) (cdr pair))) + component + (list (cons (quote key) val) ...)))) + body ...)])) |