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
|
;;; Commentary:
;; Configuration system.
;;; Code:
(define-module (calp util config)
:use-module (hnh util)
:use-module (srfi srfi-1)
:use-module (ice-9 format) ; for format-procedure
:use-module (ice-9 curried-definitions) ; for ensure
: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)
(aif (hashq-ref config-properties key)
(set! (it name) value)
(error "Missing config protperty slot " key)))
(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)
;; TODO throw descript error
(error "Missing config" key))
v)
(hashq-ref config-values key default)))
(define-public ((ensure predicate) value)
(if (predicate value)
value #f))
;; (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)
;; TODO break this up into separate `get-all-configuration-items' and
;; `format-configuration-items' procedures
(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)))))))))))
|
