diff options
author | Hugo Hörnquist <hugo@lysator.liu.se> | 2020-04-30 18:34:06 +0200 |
---|---|---|
committer | Hugo Hörnquist <hugo@lysator.liu.se> | 2020-04-30 18:34:06 +0200 |
commit | 65dfe0abc3e898dcff5672e668aab720d5891cc8 (patch) | |
tree | 4dba2a098cfc5f8edec507df75f5102cc97445b3 /module | |
parent | Add global basedir var. (diff) | |
download | calp-65dfe0abc3e898dcff5672e668aab720d5891cc8.tar.gz calp-65dfe0abc3e898dcff5672e668aab720d5891cc8.tar.xz |
Add `app' type.
Diffstat (limited to '')
-rw-r--r-- | module/util/app.scm | 44 |
1 files changed, 44 insertions, 0 deletions
diff --git a/module/util/app.scm b/module/util/app.scm new file mode 100644 index 00000000..269812aa --- /dev/null +++ b/module/util/app.scm @@ -0,0 +1,44 @@ +(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 (getf app field) + (aif (hashq-ref (get-ht app) field) + (force it) + #f)) + +(define-syntax setf% + (syntax-rules () + [(_ app field value) + (hashq-set! (get-ht app) field (delay (begin value)))])) + +(define-syntax setf + (syntax-rules () + [(_ app) app] + [(_ app key value rest ...) + (begin (setf% app key value) + (setf app rest ...))])) |