Commit | Line | Data |
---|---|---|
c0cd1b3e LC |
1 | ;;; GNU Guix --- Functional package management for GNU |
2 | ;;; Copyright © 2012, 2013 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 | #:export (define-record-type* | |
25 | alist->record | |
26 | object->fields)) | |
27 | ||
28 | ;;; Commentary: | |
29 | ;;; | |
30 | ;;; Utilities for dealing with Scheme records. | |
31 | ;;; | |
32 | ;;; Code: | |
33 | ||
34 | (define-syntax define-record-type* | |
35 | (lambda (s) | |
36 | "Define the given record type such that an additional \"syntactic | |
37 | constructor\" is defined, which allows instances to be constructed with named | |
38 | field initializers, à la SRFI-35, as well as default values." | |
39 | (define (make-syntactic-constructor type name ctor fields thunked defaults) | |
40 | "Make the syntactic constructor NAME for TYPE, that calls CTOR, and | |
41 | expects all of FIELDS to be initialized. DEFAULTS is the list of | |
42 | FIELD/DEFAULT-VALUE tuples, and THUNKED is the list of identifiers of | |
43 | thunked fields." | |
44 | (with-syntax ((type type) | |
45 | (name name) | |
46 | (ctor ctor) | |
47 | (expected fields) | |
48 | (defaults defaults)) | |
49 | #`(define-syntax name | |
50 | (lambda (s) | |
51 | (define (record-inheritance orig-record field+value) | |
52 | ;; Produce code that returns a record identical to | |
53 | ;; ORIG-RECORD, except that values for the FIELD+VALUE alist | |
54 | ;; prevail. | |
55 | (define (field-inherited-value f) | |
56 | (and=> (find (lambda (x) | |
57 | (eq? f (car (syntax->datum x)))) | |
58 | field+value) | |
59 | car)) | |
60 | ||
61 | #`(make-struct type 0 | |
62 | #,@(map (lambda (field index) | |
63 | (or (field-inherited-value field) | |
64 | #`(struct-ref #,orig-record | |
65 | #,index))) | |
66 | 'expected | |
67 | (iota (length 'expected))))) | |
68 | ||
69 | (define (thunked-field? f) | |
70 | (memq (syntax->datum f) '#,thunked)) | |
71 | ||
72 | (define (field-bindings field+value) | |
73 | ;; Return field to value bindings, for use in `letrec*' below. | |
74 | (map (lambda (field+value) | |
75 | (syntax-case field+value () | |
76 | ((field value) | |
77 | #`(field | |
78 | #,(if (thunked-field? #'field) | |
79 | #'(lambda () value) | |
80 | #'value))))) | |
81 | field+value)) | |
82 | ||
83 | (syntax-case s (inherit #,@fields) | |
84 | ((_ (inherit orig-record) (field value) (... ...)) | |
85 | #`(letrec* #,(field-bindings #'((field value) (... ...))) | |
86 | #,(record-inheritance #'orig-record | |
87 | #'((field value) (... ...))))) | |
88 | ((_ (field value) (... ...)) | |
89 | (let ((fields (map syntax->datum #'(field (... ...)))) | |
90 | (dflt (map (match-lambda | |
91 | ((f v) | |
92 | (list (syntax->datum f) v))) | |
93 | #'defaults))) | |
94 | ||
95 | (define (field-value f) | |
96 | (or (and=> (find (lambda (x) | |
97 | (eq? f (car (syntax->datum x)))) | |
98 | #'((field value) (... ...))) | |
99 | car) | |
100 | (let ((value | |
101 | (car (assoc-ref dflt | |
102 | (syntax->datum f))))) | |
103 | (if (thunked-field? f) | |
104 | #`(lambda () #,value) | |
105 | value)))) | |
106 | ||
107 | (let-syntax ((error* | |
108 | (syntax-rules () | |
109 | ((_ fmt args (... ...)) | |
110 | (syntax-violation 'name | |
111 | (format #f fmt args | |
112 | (... ...)) | |
113 | s))))) | |
114 | (let ((fields (append fields (map car dflt)))) | |
115 | (cond ((lset= eq? fields 'expected) | |
116 | #`(letrec* #,(field-bindings | |
117 | #'((field value) (... ...))) | |
118 | (ctor #,@(map field-value 'expected)))) | |
119 | ((pair? (lset-difference eq? fields 'expected)) | |
120 | (error* "extraneous field initializers ~a" | |
121 | (lset-difference eq? fields 'expected))) | |
122 | (else | |
123 | (error* "missing field initializers ~a" | |
124 | (lset-difference eq? 'expected | |
125 | fields))))))))))))) | |
126 | ||
127 | (define (field-default-value s) | |
128 | (syntax-case s (default) | |
129 | ((field (default val) _ ...) | |
130 | (list #'field #'val)) | |
131 | ((field _ options ...) | |
132 | (field-default-value #'(field options ...))) | |
133 | (_ #f))) | |
134 | ||
135 | (define (thunked-field? s) | |
136 | ;; Return the field name if the field defined by S is thunked. | |
137 | (syntax-case s (thunked) | |
138 | ((field (thunked) _ ...) | |
139 | #'field) | |
140 | ((field _ options ...) | |
141 | (thunked-field? #'(field options ...))) | |
142 | (_ #f))) | |
143 | ||
144 | (define (thunked-field-accessor-name field) | |
145 | ;; Return the name (an unhygienic syntax object) of the "real" | |
146 | ;; getter for field, which is assumed to be a thunked field. | |
147 | (syntax-case field () | |
148 | ((field get options ...) | |
149 | (let* ((getter (syntax->datum #'get)) | |
150 | (real-getter (symbol-append '% getter '-real))) | |
151 | (datum->syntax #'get real-getter))))) | |
152 | ||
153 | (define (field-spec->srfi-9 field) | |
154 | ;; Convert a field spec of our style to a SRFI-9 field spec of the | |
155 | ;; form (field get). | |
156 | (syntax-case field () | |
157 | ((name get options ...) | |
158 | #`(name | |
159 | #,(if (thunked-field? field) | |
160 | (thunked-field-accessor-name field) | |
161 | #'get))))) | |
162 | ||
163 | (define (thunked-field-accessor-definition field) | |
164 | ;; Return the real accessor for FIELD, which is assumed to be a | |
165 | ;; thunked field. | |
166 | (syntax-case field () | |
167 | ((name get _ ...) | |
168 | (with-syntax ((real-get (thunked-field-accessor-name field))) | |
169 | #'(define-inlinable (get x) | |
170 | ;; The real value of that field is a thunk, so call it. | |
171 | ((real-get x))))))) | |
172 | ||
173 | (syntax-case s () | |
174 | ((_ type syntactic-ctor ctor pred | |
175 | (field get options ...) ...) | |
176 | (let* ((field-spec #'((field get options ...) ...))) | |
177 | (with-syntax (((field-spec* ...) | |
178 | (map field-spec->srfi-9 field-spec)) | |
179 | ((thunked-field-accessor ...) | |
180 | (filter-map (lambda (field) | |
181 | (and (thunked-field? field) | |
182 | (thunked-field-accessor-definition | |
183 | field))) | |
184 | field-spec))) | |
185 | #`(begin | |
186 | (define-record-type type | |
187 | (ctor field ...) | |
188 | pred | |
189 | field-spec* ...) | |
190 | (begin thunked-field-accessor ...) | |
191 | #,(make-syntactic-constructor #'type #'syntactic-ctor #'ctor | |
192 | #'(field ...) | |
193 | (filter-map thunked-field? field-spec) | |
194 | (filter-map field-default-value | |
195 | #'((field options ...) | |
196 | ...)))))))))) | |
197 | ||
198 | (define (alist->record alist make keys) | |
199 | "Apply MAKE to the values associated with KEYS in ALIST." | |
200 | (let ((args (map (cut assoc-ref alist <>) keys))) | |
201 | (apply make args))) | |
202 | ||
203 | (define (object->fields object fields port) | |
204 | "Write OBJECT (typically a record) as a series of recutils-style fields to | |
205 | PORT, according to FIELDS. FIELDS must be a list of field name/getter pairs." | |
206 | (let loop ((fields fields)) | |
207 | (match fields | |
208 | (() | |
209 | object) | |
210 | (((field . get) rest ...) | |
211 | (format port "~a: ~a~%" field (get object)) | |
212 | (loop rest))))) | |
213 | ||
214 | ;;; records.scm ends here |