blob: aba2cd2cafafe41b12646ebc5e4ca8864a50c184 (
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
65
|
;;; 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 ensure))
(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-rule (define-once-public symbol binding)
(begin (define-once symbol binding)
(export symbol)))
(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))))
#`(define-once-public 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 #'()))))))))
(define ((ensure predicate) value)
(if (predicate value)
value #f))
|
