From 65dfe0abc3e898dcff5672e668aab720d5891cc8 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Hugo=20H=C3=B6rnquist?= <hugo@lysator.liu.se>
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 <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 ...))]))
-- 
cgit v1.2.3


From fe294992fda2015305c9f85725e8b68a1b3ccfeb Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Hugo=20H=C3=B6rnquist?= <hugo@lysator.liu.se>
Date: Thu, 30 Apr 2020 19:01:31 +0200
Subject: Minor changes.

---
 module/util/app.scm | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

(limited to 'module/util')

diff --git a/module/util/app.scm b/module/util/app.scm
index 269812aa..95df741a 100644
--- a/module/util/app.scm
+++ b/module/util/app.scm
@@ -29,7 +29,7 @@
 (define (getf app field)
   (aif (hashq-ref (get-ht app) field)
        (force it)
-       #f))
+       (error "No field" field)))
 
 (define-syntax setf%
   (syntax-rules ()
-- 
cgit v1.2.3


From aa44c16ce953c090b2eb3ce580c60fa8934a7720 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?Hugo=20H=C3=B6rnquist?= <hugo@lysator.liu.se>
Date: Thu, 30 Apr 2020 19:17:35 +0200
Subject: Change call signature for [gs]etf.

---
 module/util/app.scm | 10 ++++++++--
 1 file changed, 8 insertions(+), 2 deletions(-)

(limited to 'module/util')

diff --git a/module/util/app.scm b/module/util/app.scm
index 95df741a..e5b03b0f 100644
--- a/module/util/app.scm
+++ b/module/util/app.scm
@@ -26,18 +26,24 @@
             body ...))])))
 
 
-(define (getf app field)
+(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 (begin 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)
-- 
cgit v1.2.3