Merge branch 'origin/core-updates-next' into core-updates
[jackhill/guix/guix.git] / guix / records.scm
1 ;;; GNU Guix --- Functional package management for GNU
2 ;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018 Ludovic Courtès <ludo@gnu.org>
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)
24 #:use-module (ice-9 regex)
25 #:use-module (ice-9 rdelim)
26 #:export (define-record-type*
27 alist->record
28 object->fields
29 recutils->alist
30 match-record))
31
32 ;;; Commentary:
33 ;;;
34 ;;; Utilities for dealing with Scheme records.
35 ;;;
36 ;;; Code:
37
38 (define-syntax record-error
39 (syntax-rules ()
40 "Report a syntactic error in use of CONSTRUCTOR."
41 ((_ constructor form fmt args ...)
42 (syntax-violation constructor
43 (format #f fmt args ...)
44 form))))
45
46 (define (report-invalid-field-specifier name bindings)
47 "Report the first invalid binding among BINDINGS."
48 (let loop ((bindings bindings))
49 (syntax-case bindings ()
50 (((field value) rest ...) ;good
51 (loop #'(rest ...)))
52 ((weird _ ...) ;weird!
53 (syntax-violation name "invalid field specifier" #'weird)))))
54
55 (define (print-record-abi-mismatch-error port key args
56 default-printer)
57 (match args
58 ((rtd . _)
59 ;; The source file where this exception is thrown must be recompiled.
60 (format port "ERROR: ~a: record ABI mismatch; recompilation needed"
61 rtd))))
62
63 (set-exception-printer! 'record-abi-mismatch-error
64 print-record-abi-mismatch-error)
65
66 (eval-when (expand load eval)
67 ;; The procedures below are needed both at run time and at expansion time.
68
69 (define (current-abi-identifier type)
70 "Return an identifier unhygienically derived from TYPE for use as its
71 \"current ABI\" variable."
72 (let ((type-name (syntax->datum type)))
73 (datum->syntax
74 type
75 (string->symbol
76 (string-append "% " (symbol->string type-name)
77 " abi-cookie")))))
78
79 (define (abi-check type cookie)
80 "Return syntax that checks that the current \"application binary
81 interface\" (ABI) for TYPE is equal to COOKIE."
82 (with-syntax ((current-abi (current-abi-identifier type)))
83 #`(unless (eq? current-abi #,cookie)
84 (throw 'record-abi-mismatch-error #,type)))))
85
86 (define-syntax make-syntactic-constructor
87 (syntax-rules ()
88 "Make the syntactic constructor NAME for TYPE, that calls CTOR, and
89 expects all of EXPECTED fields to be initialized. DEFAULTS is the list of
90 FIELD/DEFAULT-VALUE tuples, THUNKED is the list of identifiers of thunked
91 fields, and DELAYED is the list of identifiers of delayed fields.
92
93 ABI-COOKIE is the cookie (an integer) against which to check the run-time ABI
94 of TYPE matches the expansion-time ABI."
95 ((_ type name ctor (expected ...)
96 #:abi-cookie abi-cookie
97 #:thunked thunked
98 #:delayed delayed
99 #:innate innate
100 #:defaults defaults)
101 (define-syntax name
102 (lambda (s)
103 (define (record-inheritance orig-record field+value)
104 ;; Produce code that returns a record identical to ORIG-RECORD,
105 ;; except that values for the FIELD+VALUE alist prevail.
106 (define (field-inherited-value f)
107 (and=> (find (lambda (x)
108 (eq? f (car (syntax->datum x))))
109 field+value)
110 car))
111
112 ;; Make sure there are no unknown field names.
113 (let* ((fields (map (compose car syntax->datum) field+value))
114 (unexpected (lset-difference eq? fields '(expected ...))))
115 (when (pair? unexpected)
116 (record-error 'name s "extraneous field initializers ~a"
117 unexpected)))
118
119 #`(make-struct/no-tail type
120 #,@(map (lambda (field index)
121 (or (field-inherited-value field)
122 (if (innate-field? field)
123 (wrap-field-value
124 field (field-default-value field))
125 #`(struct-ref #,orig-record
126 #,index))))
127 '(expected ...)
128 (iota (length '(expected ...))))))
129
130 (define (thunked-field? f)
131 (memq (syntax->datum f) 'thunked))
132
133 (define (delayed-field? f)
134 (memq (syntax->datum f) 'delayed))
135
136 (define (innate-field? f)
137 (memq (syntax->datum f) 'innate))
138
139 (define (wrap-field-value f value)
140 (cond ((thunked-field? f)
141 #`(lambda () #,value))
142 ((delayed-field? f)
143 #`(delay #,value))
144 (else value)))
145
146 (define default-values
147 ;; List of symbol/value tuples.
148 (map (match-lambda
149 ((f v)
150 (list (syntax->datum f) v)))
151 #'defaults))
152
153 (define (field-default-value f)
154 (car (assoc-ref default-values (syntax->datum f))))
155
156 (define (field-bindings field+value)
157 ;; Return field to value bindings, for use in 'let*' below.
158 (map (lambda (field+value)
159 (syntax-case field+value ()
160 ((field value)
161 #`(field
162 #,(wrap-field-value #'field #'value)))))
163 field+value))
164
165 (syntax-case s (inherit expected ...)
166 ((_ (inherit orig-record) (field value) (... ...))
167 #`(let* #,(field-bindings #'((field value) (... ...)))
168 #,(abi-check #'type abi-cookie)
169 #,(record-inheritance #'orig-record
170 #'((field value) (... ...)))))
171 ((_ (field value) (... ...))
172 (let ((fields (map syntax->datum #'(field (... ...)))))
173 (define (field-value f)
174 (or (find (lambda (x)
175 (eq? f (syntax->datum x)))
176 #'(field (... ...)))
177 (wrap-field-value f (field-default-value f))))
178
179 (let ((fields (append fields (map car default-values))))
180 (cond ((lset= eq? fields '(expected ...))
181 #`(let* #,(field-bindings
182 #'((field value) (... ...)))
183 #,(abi-check #'type abi-cookie)
184 (ctor #,@(map field-value '(expected ...)))))
185 ((pair? (lset-difference eq? fields
186 '(expected ...)))
187 (record-error 'name s
188 "extraneous field initializers ~a"
189 (lset-difference eq? fields
190 '(expected ...))))
191 (else
192 (record-error 'name s
193 "missing field initializers ~a"
194 (lset-difference eq?
195 '(expected ...)
196 fields)))))))
197 ((_ bindings (... ...))
198 ;; One of BINDINGS doesn't match the (field value) pattern.
199 ;; Report precisely which one is faulty, instead of letting the
200 ;; "source expression failed to match any pattern" error.
201 (report-invalid-field-specifier 'name
202 #'(bindings (... ...))))))))))
203
204 (define-syntax-rule (define-field-property-predicate predicate property)
205 "Define PREDICATE as a procedure that takes a syntax object and, when passed
206 a field specification, returns the field name if it has the given PROPERTY."
207 (define (predicate s)
208 (syntax-case s (property)
209 ((field (property values (... ...)) _ (... ...))
210 #'field)
211 ((field _ properties (... ...))
212 (predicate #'(field properties (... ...))))
213 (_ #f))))
214
215 (define-syntax define-record-type*
216 (lambda (s)
217 "Define the given record type such that an additional \"syntactic
218 constructor\" is defined, which allows instances to be constructed with named
219 field initializers, à la SRFI-35, as well as default values. An example use
220 may look like this:
221
222 (define-record-type* <thing> thing make-thing
223 thing?
224 (name thing-name (default \"chbouib\"))
225 (port thing-port
226 (default (current-output-port)) (thunked))
227 (loc thing-location (innate) (default (current-source-location))))
228
229 This example defines a macro 'thing' that can be used to instantiate records
230 of this type:
231
232 (thing
233 (name \"foo\")
234 (port (current-error-port)))
235
236 The value of 'name' or 'port' could as well be omitted, in which case the
237 default value specified in the 'define-record-type*' form is used:
238
239 (thing)
240
241 The 'port' field is \"thunked\", meaning that calls like '(thing-port x)' will
242 actually compute the field's value in the current dynamic extent, which is
243 useful when referring to fluids in a field's value.
244
245 A field can also be marked as \"delayed\" instead of \"thunked\", in which
246 case its value is effectively wrapped in a (delay …) form.
247
248 It is possible to copy an object 'x' created with 'thing' like this:
249
250 (thing (inherit x) (name \"bar\"))
251
252 This expression returns a new object equal to 'x' except for its 'name'
253 field and its 'loc' field---the latter is marked as \"innate\", so it is not
254 inherited."
255
256 (define (field-default-value s)
257 (syntax-case s (default)
258 ((field (default val) _ ...)
259 (list #'field #'val))
260 ((field _ properties ...)
261 (field-default-value #'(field properties ...)))
262 (_ #f)))
263
264 (define-field-property-predicate delayed-field? delayed)
265 (define-field-property-predicate thunked-field? thunked)
266 (define-field-property-predicate innate-field? innate)
267
268 (define (wrapped-field? s)
269 (or (thunked-field? s) (delayed-field? s)))
270
271 (define (wrapped-field-accessor-name field)
272 ;; Return the name (an unhygienic syntax object) of the "real"
273 ;; getter for field, which is assumed to be a wrapped field.
274 (syntax-case field ()
275 ((field get properties ...)
276 (let* ((getter (syntax->datum #'get))
277 (real-getter (symbol-append '% getter '-real)))
278 (datum->syntax #'get real-getter)))))
279
280 (define (field-spec->srfi-9 field)
281 ;; Convert a field spec of our style to a SRFI-9 field spec of the
282 ;; form (field get).
283 (syntax-case field ()
284 ((name get properties ...)
285 #`(name
286 #,(if (wrapped-field? field)
287 (wrapped-field-accessor-name field)
288 #'get)))))
289
290 (define (thunked-field-accessor-definition field)
291 ;; Return the real accessor for FIELD, which is assumed to be a
292 ;; thunked field.
293 (syntax-case field ()
294 ((name get _ ...)
295 (with-syntax ((real-get (wrapped-field-accessor-name field)))
296 #'(define-inlinable (get x)
297 ;; The real value of that field is a thunk, so call it.
298 ((real-get x)))))))
299
300 (define (delayed-field-accessor-definition field)
301 ;; Return the real accessor for FIELD, which is assumed to be a
302 ;; delayed field.
303 (syntax-case field ()
304 ((name get _ ...)
305 (with-syntax ((real-get (wrapped-field-accessor-name field)))
306 #'(define-inlinable (get x)
307 ;; The real value of that field is a promise, so force it.
308 (force (real-get x)))))))
309
310 (define (compute-abi-cookie field-specs)
311 ;; Compute an "ABI cookie" for the given FIELD-SPECS. We use
312 ;; 'string-hash' because that's a better hash function that 'hash' on a
313 ;; list of symbols.
314 (syntax-case field-specs ()
315 (((field get properties ...) ...)
316 (string-hash (object->string
317 (syntax->datum #'((field properties ...) ...)))
318 most-positive-fixnum))))
319
320 (syntax-case s ()
321 ((_ type syntactic-ctor ctor pred
322 (field get properties ...) ...)
323 (let* ((field-spec #'((field get properties ...) ...))
324 (thunked (filter-map thunked-field? field-spec))
325 (delayed (filter-map delayed-field? field-spec))
326 (innate (filter-map innate-field? field-spec))
327 (defaults (filter-map field-default-value
328 #'((field properties ...) ...)))
329 (cookie (compute-abi-cookie field-spec)))
330 (with-syntax (((field-spec* ...)
331 (map field-spec->srfi-9 field-spec))
332 ((thunked-field-accessor ...)
333 (filter-map (lambda (field)
334 (and (thunked-field? field)
335 (thunked-field-accessor-definition
336 field)))
337 field-spec))
338 ((delayed-field-accessor ...)
339 (filter-map (lambda (field)
340 (and (delayed-field? field)
341 (delayed-field-accessor-definition
342 field)))
343 field-spec)))
344 #`(begin
345 (define-record-type type
346 (ctor field ...)
347 pred
348 field-spec* ...)
349 (define #,(current-abi-identifier #'type)
350 #,cookie)
351 thunked-field-accessor ...
352 delayed-field-accessor ...
353 (make-syntactic-constructor type syntactic-ctor ctor
354 (field ...)
355 #:abi-cookie #,cookie
356 #:thunked #,thunked
357 #:delayed #,delayed
358 #:innate #,innate
359 #:defaults #,defaults))))))))
360
361 (define* (alist->record alist make keys
362 #:optional (multiple-value-keys '()))
363 "Apply MAKE to the values associated with KEYS in ALIST. Items in KEYS that
364 are also in MULTIPLE-VALUE-KEYS are considered to occur possibly multiple
365 times in ALIST, and thus their value is a list."
366 (let ((args (map (lambda (key)
367 (if (member key multiple-value-keys)
368 (filter-map (match-lambda
369 ((k . v)
370 (and (equal? k key) v)))
371 alist)
372 (assoc-ref alist key)))
373 keys)))
374 (apply make args)))
375
376 (define (object->fields object fields port)
377 "Write OBJECT (typically a record) as a series of recutils-style fields to
378 PORT, according to FIELDS. FIELDS must be a list of field name/getter pairs."
379 (let loop ((fields fields))
380 (match fields
381 (()
382 object)
383 (((field . get) rest ...)
384 (format port "~a: ~a~%" field (get object))
385 (loop rest)))))
386
387 (define %recutils-field-charset
388 ;; Valid characters starting a recutils field.
389 ;; info "(recutils) Fields"
390 (char-set-union char-set:upper-case
391 char-set:lower-case
392 (char-set #\%)))
393
394 (define (recutils->alist port)
395 "Read a recutils-style record from PORT and return it as a list of key/value
396 pairs. Stop upon an empty line (after consuming it) or EOF."
397 (let loop ((line (read-line port))
398 (result '()))
399 (cond ((eof-object? line)
400 (reverse result))
401 ((string-null? line)
402 (if (null? result)
403 (loop (read-line port) result) ; leading space: ignore it
404 (reverse result))) ; end-of-record marker
405 (else
406 ;; Now check the first character of LINE, since that's what the
407 ;; recutils manual says is enough.
408 (let ((first (string-ref line 0)))
409 (cond
410 ((char-set-contains? %recutils-field-charset first)
411 (let* ((colon (string-index line #\:))
412 (field (string-take line colon))
413 (value (string-trim (string-drop line (+ 1 colon)))))
414 (loop (read-line port)
415 (alist-cons field value result))))
416 ((eqv? first #\#) ;info "(recutils) Comments"
417 (loop (read-line port) result))
418 ((eqv? first #\+) ;info "(recutils) Fields"
419 (let ((new-line (if (string-prefix? "+ " line)
420 (string-drop line 2)
421 (string-drop line 1))))
422 (match result
423 (((field . value) rest ...)
424 (loop (read-line port)
425 `((,field . ,(string-append value "\n" new-line))
426 ,@rest))))))
427 (else
428 (error "unmatched line" line))))))))
429
430 (define-syntax match-record
431 (syntax-rules ()
432 "Bind each FIELD of a RECORD of the given TYPE to it's FIELD name.
433 The current implementation does not support thunked and delayed fields."
434 ((_ record type (field fields ...) body ...)
435 (if (eq? (struct-vtable record) type)
436 ;; TODO compute indices and report wrong-field-name errors at
437 ;; expansion time
438 ;; TODO support thunked and delayed fields
439 (let ((field ((record-accessor type 'field) record)))
440 (match-record record type (fields ...) body ...))
441 (throw 'wrong-type-arg record)))
442 ((_ record type () body ...)
443 (begin body ...))))
444
445 ;;; records.scm ends here