From 65dfe0abc3e898dcff5672e668aab720d5891cc8 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Hugo=20H=C3=B6rnquist?= Date: Thu, 30 Apr 2020 18:34:06 +0200 Subject: Add `app' type. --- module/util/app.scm | 44 ++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 44 insertions(+) create mode 100644 module/util/app.scm (limited to 'module/util') 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 + (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 ...))])) -- cgit v1.2.3