diff options
author | Hugo Hörnquist <hugo@lysator.liu.se> | 2020-05-01 13:08:25 +0200 |
---|---|---|
committer | Hugo Hörnquist <hugo@lysator.liu.se> | 2020-05-01 13:08:25 +0200 |
commit | 29cb0b9eb8e544d0f2b07eb202d90bed4f20eeea (patch) | |
tree | 92c5f2a5271911930a15e58df862273b3a755e5d /module/util/app.scm | |
parent | Server server any subdir under static. (diff) | |
parent | Change call signature for [gs]etf. (diff) | |
download | calp-29cb0b9eb8e544d0f2b07eb202d90bed4f20eeea.tar.gz calp-29cb0b9eb8e544d0f2b07eb202d90bed4f20eeea.tar.xz |
Merge branch 'app'.
The app objects both makes the whole program sort of behave like one
class in some object oriented languages, with an implicitly (actually
hiddenly explicitly) passed 'app' argument to all methods. Multiple
concurrent apps should be supported, but is of now untested.
The app is also configured to lazily bind all its fields, which means
that almost all loading is now lazy!
Diffstat (limited to '')
-rw-r--r-- | module/util/app.scm | 50 |
1 files changed, 50 insertions, 0 deletions
diff --git a/module/util/app.scm b/module/util/app.scm new file mode 100644 index 00000000..e5b03b0f --- /dev/null +++ b/module/util/app.scm @@ -0,0 +1,50 @@ +(define-module (util app) + :use-module (util) + :use-module (srfi srfi-1) + :use-module (srfi srfi-9) + :use-module (srfi srfi-9 gnu) + :export (make-app current-app define-method getf setf) + ) + +(define-immutable-record-type <app> + (make-app% ht) app? (ht get-ht)) + +(define-public (make-app) + (make-app% (make-hash-table))) + +(define current-app (make-parameter (make-app))) + +(define-syntax (define-method stx) + (with-syntax ((app (datum->syntax stx 'app))) + (syntax-case stx () + [(_ (name args ...) body ...) + + (let* ((pre post (break (lambda (s) (eqv? key: (syntax->datum s))) + #'(args ...)))) + #`(define*-public (name #,@pre #,@(if (null? post) '(key:) post) + (app (current-app))) + body ...))]))) + + +(define-method (getf field) + (aif (hashq-ref (get-ht app) field) + (force it) + (error "No field" field))) + +(define-syntax setf% + (syntax-rules () + [(_ field value) + (setf% (current-app) field value)] + [(_ app field value) + (hashq-set! (get-ht app) field (delay value))])) + +(define-syntax setf + (syntax-rules () + ;; special case to use current appp) + [(_ key value) + (setf% key value)] + + [(_ app) app] + [(_ app key value rest ...) + (begin (setf% app key value) + (setf app rest ...))])) |