Commit | Line | Data |
---|---|---|
c0cd1b3e | 1 | ;;; GNU Guix --- Functional package management for GNU |
fb519bd8 | 2 | ;;; Copyright © 2012, 2013, 2014, 2015 Ludovic Courtès <ludo@gnu.org> |
c0cd1b3e LC |
3 | ;;; |
4 | ;;; This file is part of GNU Guix. | |
5 | ;;; | |
6 | ;;; GNU Guix is free software; you can redistribute it and/or modify it | |
7 | ;;; under the terms of the GNU General Public License as published by | |
8 | ;;; the Free Software Foundation; either version 3 of the License, or (at | |
9 | ;;; your option) any later version. | |
10 | ;;; | |
11 | ;;; GNU Guix is distributed in the hope that it will be useful, but | |
12 | ;;; WITHOUT ANY WARRANTY; without even the implied warranty of | |
13 | ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the | |
14 | ;;; GNU General Public License for more details. | |
15 | ;;; | |
16 | ;;; You should have received a copy of the GNU General Public License | |
17 | ;;; along with GNU Guix. If not, see <http://www.gnu.org/licenses/>. | |
18 | ||
19 | (define-module (guix records) | |
20 | #:use-module (srfi srfi-1) | |
21 | #:use-module (srfi srfi-9) | |
22 | #:use-module (srfi srfi-26) | |
23 | #:use-module (ice-9 match) | |
fdc1bf65 LC |
24 | #:use-module (ice-9 regex) |
25 | #:use-module (ice-9 rdelim) | |
c0cd1b3e LC |
26 | #:export (define-record-type* |
27 | alist->record | |
fdc1bf65 LC |
28 | object->fields |
29 | recutils->alist)) | |
c0cd1b3e LC |
30 | |
31 | ;;; Commentary: | |
32 | ;;; | |
33 | ;;; Utilities for dealing with Scheme records. | |
34 | ;;; | |
35 | ;;; Code: | |
36 | ||
b1353e7a LC |
37 | (define-syntax record-error |
38 | (syntax-rules () | |
39 | "Report a syntactic error in use of CONSTRUCTOR." | |
40 | ((_ constructor form fmt args ...) | |
41 | (syntax-violation constructor | |
42 | (format #f fmt args ...) | |
43 | form)))) | |
44 | ||
cf4efb39 | 45 | (define* (make-syntactic-constructor type name ctor fields |
0db40ed2 | 46 | #:key (thunked '()) (defaults '())) |
cf4efb39 LC |
47 | "Make the syntactic constructor NAME for TYPE, that calls CTOR, and expects |
48 | all of FIELDS to be initialized. DEFAULTS is the list of FIELD/DEFAULT-VALUE | |
49 | tuples, and THUNKED is the list of identifiers of thunked fields." | |
50 | (with-syntax ((type type) | |
51 | (name name) | |
52 | (ctor ctor) | |
53 | (expected fields) | |
54 | (defaults defaults)) | |
55 | #`(define-syntax name | |
56 | (lambda (s) | |
57 | (define (record-inheritance orig-record field+value) | |
58 | ;; Produce code that returns a record identical to ORIG-RECORD, | |
59 | ;; except that values for the FIELD+VALUE alist prevail. | |
60 | (define (field-inherited-value f) | |
61 | (and=> (find (lambda (x) | |
62 | (eq? f (car (syntax->datum x)))) | |
63 | field+value) | |
64 | car)) | |
65 | ||
66 | ;; Make sure there are no unknown field names. | |
67 | (let* ((fields (map (compose car syntax->datum) field+value)) | |
68 | (unexpected (lset-difference eq? fields 'expected))) | |
69 | (when (pair? unexpected) | |
70 | (record-error 'name s "extraneous field initializers ~a" | |
71 | unexpected))) | |
72 | ||
73 | #`(make-struct type 0 | |
74 | #,@(map (lambda (field index) | |
75 | (or (field-inherited-value field) | |
76 | #`(struct-ref #,orig-record | |
77 | #,index))) | |
78 | 'expected | |
79 | (iota (length 'expected))))) | |
80 | ||
81 | (define (thunked-field? f) | |
82 | (memq (syntax->datum f) '#,thunked)) | |
83 | ||
c492be65 LC |
84 | (define (wrap-field-value f value) |
85 | (if (thunked-field? f) | |
86 | #`(lambda () #,value) | |
87 | value)) | |
88 | ||
cf4efb39 LC |
89 | (define (field-bindings field+value) |
90 | ;; Return field to value bindings, for use in 'let*' below. | |
91 | (map (lambda (field+value) | |
92 | (syntax-case field+value () | |
93 | ((field value) | |
94 | #`(field | |
c492be65 | 95 | #,(wrap-field-value #'field #'value))))) |
cf4efb39 LC |
96 | field+value)) |
97 | ||
98 | (syntax-case s (inherit #,@fields) | |
99 | ((_ (inherit orig-record) (field value) (... ...)) | |
100 | #`(let* #,(field-bindings #'((field value) (... ...))) | |
101 | #,(record-inheritance #'orig-record | |
102 | #'((field value) (... ...))))) | |
103 | ((_ (field value) (... ...)) | |
104 | (let ((fields (map syntax->datum #'(field (... ...)))) | |
105 | (dflt (map (match-lambda | |
106 | ((f v) | |
107 | (list (syntax->datum f) v))) | |
108 | #'defaults))) | |
109 | ||
110 | (define (field-value f) | |
111 | (or (and=> (find (lambda (x) | |
112 | (eq? f (car (syntax->datum x)))) | |
113 | #'((field value) (... ...))) | |
114 | car) | |
115 | (let ((value | |
116 | (car (assoc-ref dflt (syntax->datum f))))) | |
c492be65 | 117 | (wrap-field-value f value)))) |
cf4efb39 LC |
118 | |
119 | (let ((fields (append fields (map car dflt)))) | |
120 | (cond ((lset= eq? fields 'expected) | |
121 | #`(let* #,(field-bindings | |
122 | #'((field value) (... ...))) | |
123 | (ctor #,@(map field-value 'expected)))) | |
124 | ((pair? (lset-difference eq? fields 'expected)) | |
125 | (record-error 'name s | |
126 | "extraneous field initializers ~a" | |
127 | (lset-difference eq? fields | |
128 | 'expected))) | |
129 | (else | |
130 | (record-error 'name s | |
131 | "missing field initializers ~a" | |
132 | (lset-difference eq? 'expected | |
133 | fields)))))))))))) | |
134 | ||
c0cd1b3e LC |
135 | (define-syntax define-record-type* |
136 | (lambda (s) | |
137 | "Define the given record type such that an additional \"syntactic | |
138 | constructor\" is defined, which allows instances to be constructed with named | |
e2540884 LC |
139 | field initializers, à la SRFI-35, as well as default values. An example use |
140 | may look like this: | |
141 | ||
142 | (define-record-type* <thing> thing make-thing | |
143 | thing? | |
144 | (name thing-name (default \"chbouib\")) | |
145 | (port thing-port | |
146 | (default (current-output-port)) (thunked))) | |
147 | ||
148 | This example defines a macro 'thing' that can be used to instantiate records | |
149 | of this type: | |
150 | ||
151 | (thing | |
152 | (name \"foo\") | |
153 | (port (current-error-port))) | |
154 | ||
155 | The value of 'name' or 'port' could as well be omitted, in which case the | |
156 | default value specified in the 'define-record-type*' form is used: | |
157 | ||
158 | (thing) | |
159 | ||
160 | The 'port' field is \"thunked\", meaning that calls like '(thing-port x)' will | |
161 | actually compute the field's value in the current dynamic extent, which is | |
162 | useful when referring to fluids in a field's value. | |
163 | ||
164 | It is possible to copy an object 'x' created with 'thing' like this: | |
165 | ||
166 | (thing (inherit x) (name \"bar\")) | |
167 | ||
168 | This expression returns a new object equal to 'x' except for its 'name' | |
169 | field." | |
170 | ||
c0cd1b3e LC |
171 | (define (field-default-value s) |
172 | (syntax-case s (default) | |
173 | ((field (default val) _ ...) | |
174 | (list #'field #'val)) | |
175 | ((field _ options ...) | |
176 | (field-default-value #'(field options ...))) | |
177 | (_ #f))) | |
178 | ||
179 | (define (thunked-field? s) | |
180 | ;; Return the field name if the field defined by S is thunked. | |
181 | (syntax-case s (thunked) | |
182 | ((field (thunked) _ ...) | |
183 | #'field) | |
184 | ((field _ options ...) | |
185 | (thunked-field? #'(field options ...))) | |
186 | (_ #f))) | |
187 | ||
188 | (define (thunked-field-accessor-name field) | |
189 | ;; Return the name (an unhygienic syntax object) of the "real" | |
190 | ;; getter for field, which is assumed to be a thunked field. | |
191 | (syntax-case field () | |
192 | ((field get options ...) | |
193 | (let* ((getter (syntax->datum #'get)) | |
194 | (real-getter (symbol-append '% getter '-real))) | |
195 | (datum->syntax #'get real-getter))))) | |
196 | ||
197 | (define (field-spec->srfi-9 field) | |
198 | ;; Convert a field spec of our style to a SRFI-9 field spec of the | |
199 | ;; form (field get). | |
200 | (syntax-case field () | |
201 | ((name get options ...) | |
202 | #`(name | |
203 | #,(if (thunked-field? field) | |
204 | (thunked-field-accessor-name field) | |
205 | #'get))))) | |
206 | ||
207 | (define (thunked-field-accessor-definition field) | |
208 | ;; Return the real accessor for FIELD, which is assumed to be a | |
209 | ;; thunked field. | |
210 | (syntax-case field () | |
211 | ((name get _ ...) | |
212 | (with-syntax ((real-get (thunked-field-accessor-name field))) | |
213 | #'(define-inlinable (get x) | |
214 | ;; The real value of that field is a thunk, so call it. | |
215 | ((real-get x))))))) | |
216 | ||
217 | (syntax-case s () | |
218 | ((_ type syntactic-ctor ctor pred | |
219 | (field get options ...) ...) | |
9b543456 LC |
220 | (let* ((field-spec #'((field get options ...) ...)) |
221 | (thunked (filter-map thunked-field? field-spec)) | |
222 | (defaults (filter-map field-default-value | |
223 | #'((field options ...) ...)))) | |
c0cd1b3e LC |
224 | (with-syntax (((field-spec* ...) |
225 | (map field-spec->srfi-9 field-spec)) | |
226 | ((thunked-field-accessor ...) | |
227 | (filter-map (lambda (field) | |
228 | (and (thunked-field? field) | |
229 | (thunked-field-accessor-definition | |
230 | field))) | |
231 | field-spec))) | |
232 | #`(begin | |
233 | (define-record-type type | |
234 | (ctor field ...) | |
235 | pred | |
236 | field-spec* ...) | |
237 | (begin thunked-field-accessor ...) | |
238 | #,(make-syntactic-constructor #'type #'syntactic-ctor #'ctor | |
239 | #'(field ...) | |
9b543456 LC |
240 | #:thunked thunked |
241 | #:defaults defaults)))))))) | |
c0cd1b3e | 242 | |
c8772a7a LC |
243 | (define* (alist->record alist make keys |
244 | #:optional (multiple-value-keys '())) | |
245 | "Apply MAKE to the values associated with KEYS in ALIST. Items in KEYS that | |
246 | are also in MULTIPLE-VALUE-KEYS are considered to occur possibly multiple | |
247 | times in ALIST, and thus their value is a list." | |
248 | (let ((args (map (lambda (key) | |
249 | (if (member key multiple-value-keys) | |
250 | (filter-map (match-lambda | |
251 | ((k . v) | |
252 | (and (equal? k key) v))) | |
253 | alist) | |
254 | (assoc-ref alist key))) | |
255 | keys))) | |
c0cd1b3e LC |
256 | (apply make args))) |
257 | ||
258 | (define (object->fields object fields port) | |
259 | "Write OBJECT (typically a record) as a series of recutils-style fields to | |
260 | PORT, according to FIELDS. FIELDS must be a list of field name/getter pairs." | |
261 | (let loop ((fields fields)) | |
262 | (match fields | |
263 | (() | |
264 | object) | |
265 | (((field . get) rest ...) | |
266 | (format port "~a: ~a~%" field (get object)) | |
267 | (loop rest))))) | |
268 | ||
fb519bd8 LC |
269 | (define %recutils-field-charset |
270 | ;; Valid characters starting a recutils field. | |
271 | ;; info "(recutils) Fields" | |
272 | (char-set-union char-set:upper-case | |
273 | char-set:lower-case | |
274 | (char-set #\%))) | |
836d10f1 | 275 | |
fdc1bf65 LC |
276 | (define (recutils->alist port) |
277 | "Read a recutils-style record from PORT and return it as a list of key/value | |
278 | pairs. Stop upon an empty line (after consuming it) or EOF." | |
279 | (let loop ((line (read-line port)) | |
280 | (result '())) | |
b7b88288 | 281 | (cond ((eof-object? line) |
fdc1bf65 | 282 | (reverse result)) |
b7b88288 LC |
283 | ((string-null? line) |
284 | (if (null? result) | |
285 | (loop (read-line port) result) ; leading space: ignore it | |
286 | (reverse result))) ; end-of-record marker | |
fdc1bf65 | 287 | (else |
fb519bd8 LC |
288 | ;; Now check the first character of LINE, since that's what the |
289 | ;; recutils manual says is enough. | |
290 | (let ((first (string-ref line 0))) | |
291 | (cond | |
292 | ((char-set-contains? %recutils-field-charset first) | |
293 | (let* ((colon (string-index line #\:)) | |
294 | (field (string-take line colon)) | |
295 | (value (string-trim (string-drop line (+ 1 colon))))) | |
296 | (loop (read-line port) | |
297 | (alist-cons field value result)))) | |
298 | ((eqv? first #\#) ;info "(recutils) Comments" | |
299 | (loop (read-line port) result)) | |
300 | ((eqv? first #\+) ;info "(recutils) Fields" | |
301 | (let ((new-line (if (string-prefix? "+ " line) | |
302 | (string-drop line 2) | |
303 | (string-drop line 1)))) | |
304 | (match result | |
305 | (((field . value) rest ...) | |
306 | (loop (read-line port) | |
307 | `((,field . ,(string-append value "\n" new-line)) | |
308 | ,@rest)))))) | |
309 | (else | |
310 | (error "unmatched line" line)))))))) | |
fdc1bf65 | 311 | |
c0cd1b3e | 312 | ;;; records.scm ends here |