| blob | c02395f2ae7903136acecc3e099ff7d30a3a8cc9 |
1 ;;; GNU Guix --- Functional package management for GNU
2 ;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017 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/>.
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))
32 ;;; Commentary:
33 ;;;
34 ;;; Utilities for dealing with Scheme records.
35 ;;;
36 ;;; Code:
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))))
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)))))
55 (define-syntax make-syntactic-constructor
56 (syntax-rules ()
57 "Make the syntactic constructor NAME for TYPE, that calls CTOR, and
58 expects all of EXPECTED fields to be initialized. DEFAULTS is the list of
59 FIELD/DEFAULT-VALUE tuples, THUNKED is the list of identifiers of thunked
60 fields, and DELAYED is the list of identifiers of delayed fields."
61 ((_ type name ctor (expected ...)
62 #:thunked thunked
63 #:delayed delayed
64 #:innate innate
65 #:defaults defaults)
66 (define-syntax name
67 (lambda (s)
68 (define (record-inheritance orig-record field+value)
69 ;; Produce code that returns a record identical to ORIG-RECORD,
70 ;; except that values for the FIELD+VALUE alist prevail.
71 (define (field-inherited-value f)
72 (and=> (find (lambda (x)
73 (eq? f (car (syntax->datum x))))
74 field+value)
75 car))
77 ;; Make sure there are no unknown field names.
78 (let* ((fields (map (compose car syntax->datum) field+value))
79 (unexpected (lset-difference eq? fields '(expected ...))))
80 (when (pair? unexpected)
81 (record-error 'name s "extraneous field initializers ~a"
82 unexpected)))
84 #`(make-struct/no-tail type
85 #,@(map (lambda (field index)
86 (or (field-inherited-value field)
87 (if (innate-field? field)
88 (wrap-field-value
89 field (field-default-value field))
90 #`(struct-ref #,orig-record
91 #,index))))
92 '(expected ...)
93 (iota (length '(expected ...))))))
95 (define (thunked-field? f)
96 (memq (syntax->datum f) 'thunked))
98 (define (delayed-field? f)
99 (memq (syntax->datum f) 'delayed))
101 (define (innate-field? f)
102 (memq (syntax->datum f) 'innate))
104 (define (wrap-field-value f value)
105 (cond ((thunked-field? f)
106 #`(lambda () #,value))
107 ((delayed-field? f)
108 #`(delay #,value))
109 (else value)))
111 (define default-values
112 ;; List of symbol/value tuples.
113 (map (match-lambda
114 ((f v)
115 (list (syntax->datum f) v)))
116 #'defaults))
118 (define (field-default-value f)
119 (car (assoc-ref default-values (syntax->datum f))))
121 (define (field-bindings field+value)
122 ;; Return field to value bindings, for use in 'let*' below.
123 (map (lambda (field+value)
124 (syntax-case field+value ()
125 ((field value)
126 #`(field
127 #,(wrap-field-value #'field #'value)))))
128 field+value))
130 (syntax-case s (inherit expected ...)
131 ((_ (inherit orig-record) (field value) (... ...))
132 #`(let* #,(field-bindings #'((field value) (... ...)))
133 #,(record-inheritance #'orig-record
134 #'((field value) (... ...)))))
135 ((_ (field value) (... ...))
136 (let ((fields (map syntax->datum #'(field (... ...)))))
137 (define (field-value f)
138 (or (find (lambda (x)
139 (eq? f (syntax->datum x)))
140 #'(field (... ...)))
141 (wrap-field-value f (field-default-value f))))
143 (let ((fields (append fields (map car default-values))))
144 (cond ((lset= eq? fields '(expected ...))
145 #`(let* #,(field-bindings
146 #'((field value) (... ...)))
147 (ctor #,@(map field-value '(expected ...)))))
148 ((pair? (lset-difference eq? fields
149 '(expected ...)))
150 (record-error 'name s
151 "extraneous field initializers ~a"
152 (lset-difference eq? fields
153 '(expected ...))))
154 (else
155 (record-error 'name s
156 "missing field initializers ~a"
157 (lset-difference eq?
158 '(expected ...)
159 fields)))))))
160 ((_ bindings (... ...))
161 ;; One of BINDINGS doesn't match the (field value) pattern.
162 ;; Report precisely which one is faulty, instead of letting the
163 ;; "source expression failed to match any pattern" error.
164 (report-invalid-field-specifier 'name
165 #'(bindings (... ...))))))))))
167 (define-syntax-rule (define-field-property-predicate predicate property)
168 "Define PREDICATE as a procedure that takes a syntax object and, when passed
169 a field specification, returns the field name if it has the given PROPERTY."
170 (define (predicate s)
171 (syntax-case s (property)
172 ((field (property values (... ...)) _ (... ...))
173 #'field)
174 ((field _ properties (... ...))
175 (predicate #'(field properties (... ...))))
176 (_ #f))))
178 (define-syntax define-record-type*
179 (lambda (s)
180 "Define the given record type such that an additional \"syntactic
181 constructor\" is defined, which allows instances to be constructed with named
182 field initializers, à la SRFI-35, as well as default values. An example use
183 may look like this:
185 (define-record-type* <thing> thing make-thing
186 thing?
187 (name thing-name (default \"chbouib\"))
188 (port thing-port
189 (default (current-output-port)) (thunked))
190 (loc thing-location (innate) (default (current-source-location))))
192 This example defines a macro 'thing' that can be used to instantiate records
193 of this type:
195 (thing
196 (name \"foo\")
197 (port (current-error-port)))
199 The value of 'name' or 'port' could as well be omitted, in which case the
200 default value specified in the 'define-record-type*' form is used:
202 (thing)
204 The 'port' field is \"thunked\", meaning that calls like '(thing-port x)' will
205 actually compute the field's value in the current dynamic extent, which is
206 useful when referring to fluids in a field's value.
208 A field can also be marked as \"delayed\" instead of \"thunked\", in which
209 case its value is effectively wrapped in a (delay …) form.
211 It is possible to copy an object 'x' created with 'thing' like this:
213 (thing (inherit x) (name \"bar\"))
215 This expression returns a new object equal to 'x' except for its 'name'
216 field and its 'loc' field---the latter is marked as \"innate\", so it is not
217 inherited."
219 (define (field-default-value s)
220 (syntax-case s (default)
221 ((field (default val) _ ...)
222 (list #'field #'val))
223 ((field _ properties ...)
224 (field-default-value #'(field properties ...)))
225 (_ #f)))
227 (define-field-property-predicate delayed-field? delayed)
228 (define-field-property-predicate thunked-field? thunked)
229 (define-field-property-predicate innate-field? innate)
231 (define (wrapped-field? s)
232 (or (thunked-field? s) (delayed-field? s)))
234 (define (wrapped-field-accessor-name field)
235 ;; Return the name (an unhygienic syntax object) of the "real"
236 ;; getter for field, which is assumed to be a wrapped field.
237 (syntax-case field ()
238 ((field get properties ...)
239 (let* ((getter (syntax->datum #'get))
240 (real-getter (symbol-append '% getter '-real)))
241 (datum->syntax #'get real-getter)))))
243 (define (field-spec->srfi-9 field)
244 ;; Convert a field spec of our style to a SRFI-9 field spec of the
245 ;; form (field get).
246 (syntax-case field ()
247 ((name get properties ...)
248 #`(name
249 #,(if (wrapped-field? field)
250 (wrapped-field-accessor-name field)
251 #'get)))))
253 (define (thunked-field-accessor-definition field)
254 ;; Return the real accessor for FIELD, which is assumed to be a
255 ;; thunked field.
256 (syntax-case field ()
257 ((name get _ ...)
258 (with-syntax ((real-get (wrapped-field-accessor-name field)))
259 #'(define-inlinable (get x)
260 ;; The real value of that field is a thunk, so call it.
261 ((real-get x)))))))
263 (define (delayed-field-accessor-definition field)
264 ;; Return the real accessor for FIELD, which is assumed to be a
265 ;; delayed field.
266 (syntax-case field ()
267 ((name get _ ...)
268 (with-syntax ((real-get (wrapped-field-accessor-name field)))
269 #'(define-inlinable (get x)
270 ;; The real value of that field is a promise, so force it.
271 (force (real-get x)))))))
273 (syntax-case s ()
274 ((_ type syntactic-ctor ctor pred
275 (field get properties ...) ...)
276 (let* ((field-spec #'((field get properties ...) ...))
277 (thunked (filter-map thunked-field? field-spec))
278 (delayed (filter-map delayed-field? field-spec))
279 (innate (filter-map innate-field? field-spec))
280 (defaults (filter-map field-default-value
281 #'((field properties ...) ...))))
282 (with-syntax (((field-spec* ...)
283 (map field-spec->srfi-9 field-spec))
284 ((thunked-field-accessor ...)
285 (filter-map (lambda (field)
286 (and (thunked-field? field)
287 (thunked-field-accessor-definition
288 field)))
289 field-spec))
290 ((delayed-field-accessor ...)
291 (filter-map (lambda (field)
292 (and (delayed-field? field)
293 (delayed-field-accessor-definition
294 field)))
295 field-spec)))
296 #`(begin
297 (define-record-type type
298 (ctor field ...)
299 pred
300 field-spec* ...)
301 thunked-field-accessor ...
302 delayed-field-accessor ...
303 (make-syntactic-constructor type syntactic-ctor ctor
304 (field ...)
305 #:thunked #,thunked
306 #:delayed #,delayed
307 #:innate #,innate
308 #:defaults #,defaults))))))))
310 (define* (alist->record alist make keys
311 #:optional (multiple-value-keys '()))
312 "Apply MAKE to the values associated with KEYS in ALIST. Items in KEYS that
313 are also in MULTIPLE-VALUE-KEYS are considered to occur possibly multiple
314 times in ALIST, and thus their value is a list."
315 (let ((args (map (lambda (key)
316 (if (member key multiple-value-keys)
317 (filter-map (match-lambda
318 ((k . v)
319 (and (equal? k key) v)))
320 alist)
321 (assoc-ref alist key)))
322 keys)))
323 (apply make args)))
325 (define (object->fields object fields port)
326 "Write OBJECT (typically a record) as a series of recutils-style fields to
327 PORT, according to FIELDS. FIELDS must be a list of field name/getter pairs."
328 (let loop ((fields fields))
329 (match fields
330 (()
331 object)
332 (((field . get) rest ...)
333 (format port "~a: ~a~%" field (get object))
334 (loop rest)))))
336 (define %recutils-field-charset
337 ;; Valid characters starting a recutils field.
338 ;; info "(recutils) Fields"
339 (char-set-union char-set:upper-case
340 char-set:lower-case
341 (char-set #\%)))
343 (define (recutils->alist port)
344 "Read a recutils-style record from PORT and return it as a list of key/value
345 pairs. Stop upon an empty line (after consuming it) or EOF."
346 (let loop ((line (read-line port))
347 (result '()))
348 (cond ((eof-object? line)
349 (reverse result))
350 ((string-null? line)
351 (if (null? result)
352 (loop (read-line port) result) ; leading space: ignore it
353 (reverse result))) ; end-of-record marker
354 (else
355 ;; Now check the first character of LINE, since that's what the
356 ;; recutils manual says is enough.
357 (let ((first (string-ref line 0)))
358 (cond
359 ((char-set-contains? %recutils-field-charset first)
360 (let* ((colon (string-index line #\:))
361 (field (string-take line colon))
362 (value (string-trim (string-drop line (+ 1 colon)))))
363 (loop (read-line port)
364 (alist-cons field value result))))
365 ((eqv? first #\#) ;info "(recutils) Comments"
366 (loop (read-line port) result))
367 ((eqv? first #\+) ;info "(recutils) Fields"
368 (let ((new-line (if (string-prefix? "+ " line)
369 (string-drop line 2)
370 (string-drop line 1))))
371 (match result
372 (((field . value) rest ...)
373 (loop (read-line port)
374 `((,field . ,(string-append value "\n" new-line))
375 ,@rest))))))
376 (else
377 (error "unmatched line" line))))))))
379 (define-syntax match-record
380 (syntax-rules ()
381 "Bind each FIELD of a RECORD of the given TYPE to it's FIELD name.
382 The current implementation does not support thunked and delayed fields."
383 ((_ record type (field fields ...) body ...)
384 (if (eq? (struct-vtable record) type)
385 ;; TODO compute indices and report wrong-field-name errors at
386 ;; expansion time
387 ;; TODO support thunked and delayed fields
388 (let ((field ((record-accessor type 'field) record)))
389 (match-record record type (fields ...) body ...))
390 (throw 'wrong-type-arg record)))
391 ((_ record type () body ...)
392 (begin body ...))))
394 ;;; records.scm ends here