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