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
120
121
122
123
124
125
126
127
128
129
130
131
132
133
134
135
136
137
138
139
140
141
142
|
;;; 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-1)
:use-module (srfi srfi-9)
:use-module (srfi srfi-26)
:use-module (ice-9 match)
:use-module (ice-9 format)
:use-module (ice-9 curried-definitions) ; for ensure
:use-module (util)
:export (define-config)
)
(define-once config-values (make-hash-table))
;; properties declared before being bound into hash-map
;; to allow nicer scripting in this file.
(define-once config-properties (make-hash-table))
(define description (make-object-property))
(define source-module (make-object-property))
(define pre (make-object-property))
(define post (make-object-property))
(hashq-set! config-properties #:description description)
(hashq-set! config-properties #:source-module source-module)
(hashq-set! config-properties #:pre pre)
(hashq-set! config-properties #:post post)
;; Config cells "are" immutable. @var{set-property!} is
;; therefore intentionally unwritten.
(define-public (get-property config-name property-key)
((hashq-ref config-properties property-key) config-name))
(define (define-config% name default-value kwargs)
(for (key value) in (group kwargs 2)
(set! ((or (hashq-ref config-properties key)
(error "Missing config protperty slot " key))
name)
value))
(set-config! name (get-config name default-value)))
(define-syntax define-config
(syntax-rules ()
((_ name default kwargs ...)
(define-config% (quote name) default
(list source-module: (current-module)
kwargs ...)))))
(define-public (set-config! name value)
(hashq-set! config-values name
(aif (pre name)
(or (it value) (error "Pre crashed for" name))
value))
(awhen (post name) (it value)))
;; unique symbol here since #f is a valid configuration value.
(define %uniq (gensym))
(define*-public (get-config key optional: (default %uniq))
(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)))
(define-public ((ensure predicate) value)
(if (not (predicate value))
#f value))
;; (format-procedure (lambda (x y) ...)) => λx, y
;; (define (f x) ...)
;; (format-procedure f) => f(x)
(define (format-procedure proc)
((aif (procedure-name proc)
(lambda (s) (string-append (symbol->string it) "(" s ")"))
(lambda (s) (string-append "λ" s)))
(let ((args ((@ (ice-9 session) procedure-arguments)
proc)))
(string-join
(remove null?
(list
(awhen ((ensure (negate null?))
(assoc-ref args 'required))
(format #f "~{~a~^, ~}" it))
(awhen ((ensure (negate null?))
(assoc-ref args 'optional))
(format #f "[~{~a~^, ~}]" it))
(awhen ((ensure (negate null?))
(assoc-ref args 'keyword))
(format #f "key: ~{~a~^, ~}"
(map keyword->symbol
(map car it))))
(awhen ((ensure (negate null?))
(assoc-ref args 'rest))
(format #f "~a ..." it))))
", "))))
(export format-procedure)
(define (->str any)
(with-output-to-string
(lambda () (display any))))
(define-public (get-configuration-documentation)
(define groups
(group-by (compose source-module car)
(hash-map->list list config-values)))
`(*TOP*
(header "Configuration variables")
(dl
,@(concatenate
(for (module values) in groups
`((dt "") (dd (header ,(aif module
(->str (module-name it))
#f)))
,@(concatenate
(for (key value) in values
`((dt ,key)
(dd (p (@ (inline))
,(or (description key) "")))
(dt "V:")
(dd ,(if (procedure? value)
(format-procedure value)
`(scheme ,value))
(br)))))))))))
|
