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
66
67
68
69
70
71
72
73
74
75
76
77
78
79
80
81
82
83
84
85
86
87
88
89
90
91
92
93
94
95
96
97
98
99
100
101
102
103
104
105
106
107
108
109
110
111
112
113
114
115
116
117
118
119
|
;;; Commentary:
;; This file should define all global configurable variables which
;; doesn't belong anywhere else. The config module should then import
;; this module, and set all configs as needed. The config module
;; should also be able to set configs gotten from other parts.
;;; Code:
(define-module (util config)
:use-module (srfi srfi-9)
:use-module (srfi srfi-26)
:use-module (ice-9 match)
:use-module (ice-9 format)
:use-module (util)
:use-module (util exceptions)
)
(define-once config-values (make-hash-table))
(define-record-type <config>
(make-config value documentation source-module attributes)
config?
(value get-value set-value!)
(documentation get-documentation)
(source-module get-source-module)
(attributes config-attributes)
)
(define-record-type <un-config>
(make-unconfig value)
unconfig?
(value get-un-value))
;; similar to emacs defcustom
(define-macro (define-config name default-value documentation . rest)
(let ((make-config '(@@ (util config) make-config))
(config-values '(@@ (util config) config-values))
(config? '(@@ (util config) config?))
(get-value '(@@ (util config) get-value)))
`(cond [(hashq-ref ,config-values (quote ,name))
=> (lambda (value)
;; When reloading a module an already defined configuration item
;; might be loaded again, just anwrap it and pretend that didn't
;; happen.
(when (,config? value)
(set! value (,get-value value)))
(hashq-set! ,config-values (quote ,name)
(,make-config 'dummy ,documentation (current-module)
(list ,@rest)))
;; Fatal error when the default value doesn't work.
(catch 'config-error
(lambda () (set-config! (quote ,name) value))
(lambda (err _ fmt args __)
(apply (@ (util exceptions) fatal) fmt args))))]
;; value not set in advance
[else
(hashq-set! ,config-values (quote ,name)
(,make-config 'dummy ,documentation
(current-module) (list ,@rest)))
(catch 'config-error
(lambda () (set-config! (quote ,name) ,default-value))
(lambda (err _ fmt args __)
((@ (util exceptions) fatal) "~a ~a" fmt args)))])))
(export define-config)
(define* (config-attribute config attr optional: default)
(aif (memv attr (config-attributes config))
(cadr it)
default))
(define-public (set-config! key value)
(cond [(hashq-ref config-values key)
=> (lambda (conf)
(aif (not ((config-attribute conf #:pre (const #t))
value))
(scm-error 'config-error 'define-config
"Config [~a]: ~a doesn't sattisfy predicate ~s~%\"~a\"~%"
(list (quote ,name)
value
(get-documentation conf))
(list value))
(begin
(set-value! conf value)
((config-attribute conf #:post identity) value))))]
[else (hashq-set! config-values key (make-unconfig value))]))
;; unique symbol here since #f is a valid configuration value.
(define %uniq (gensym))
(define*-public (get-config key optional: (default %uniq))
(let ((v (if (eq? default %uniq)
(let ((v (hashq-ref config-values key %uniq)))
(when (eq? v %uniq)
(error "Missing config" key))
v)
(hashq-ref config-values key default))))
(if (config? v)
(get-value v)
v)))
(define-public (print-configuration-documentation)
(define groups
(group-by (match-lambda [(__ v)
(if (config? v)
(get-source-module v)
#f)])
(hash-map->list list config-values )) )
(for (module values) in groups
(format #t "~%~a~%" (module-name module))
(for (key value) in values
(format #t " ~20,a | ~a~%" key (get-documentation value)))))
|
