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