diff options
-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 ...))])) |