blob: b2a46ea7119f6fdff4735787633c86d943ae9f61 (
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
51
52
53
54
55
56
57
58
59
60
61
62
63
64
|
;;; Commentary:
;; Configuration system.
;;; Code:
(define-module (calp util config)
:use-module (hnh util)
:use-module (srfi srfi-1)
:use-module (ice-9 curried-definitions) ; for ensure
:use-module (calp translation)
:export (define-config)
)
(define (fix-keywords args)
(map (lambda (arg)
(if (keyword? (syntax->datum arg))
(syntax->datum arg)
arg))
args))
(define %configuration-error
(_ "Pre-property failed when setting ~s to ~s"))
(define-syntax (define-config stx)
(syntax-case stx ()
((_ name default kw ...)
(let ((pre (cond ((memv pre: (fix-keywords #'(kw ...))) => cadr) (else #f)))
(post (cond ((memv post: (fix-keywords #'(kw ...))) => cadr) (else #f))))
#`(begin
(define-once name
(make-parameter
default
#,@(cond ((and pre post)
#`((lambda (new-value)
(cond ((#,pre new-value)
=> (lambda (translated)
(#,post translated)
translated))
(else
(scm-error 'configuration-error
"set-config!"
%configuration-error
(list (quote name) new-value)))))))
(pre
#`((lambda (new-value)
(or (#,pre new-value)
(scm-error 'configuration-error
"set-config!"
%configuration-error
(list (quote name) new-value))))))
(post
#`((lambda (new-value)
(#,post new-value)
new-value))
)
(else #'()))))
(export name))))))
(define-public ((ensure predicate) value)
(if (predicate value)
value #f))
|