blob: e5b03b0f4393a0a42eab396ab9b3ccdf12af5331 (
plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
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 ...))]))
|