| 1 | ;;; GNU Guix --- Functional package management for GNU |
| 2 | ;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019 Ludovic Courtès <ludo@gnu.org> |
| 3 | ;;; Copyright © 2018 Mark H Weaver <mhw@netris.org> |
| 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) |
| 25 | #:use-module (ice-9 regex) |
| 26 | #:use-module (ice-9 rdelim) |
| 27 | #:export (define-record-type* |
| 28 | this-record |
| 29 | |
| 30 | alist->record |
| 31 | object->fields |
| 32 | recutils->alist |
| 33 | match-record)) |
| 34 | |
| 35 | ;;; Commentary: |
| 36 | ;;; |
| 37 | ;;; Utilities for dealing with Scheme records. |
| 38 | ;;; |
| 39 | ;;; Code: |
| 40 | |
| 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 | |
| 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 |
| 54 | \"current ABI\" variable." |
| 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"))))) |
| 61 | |
| 62 | (define (abi-check type cookie) |
| 63 | "Return syntax that checks that the current \"application binary |
| 64 | interface\" (ABI) for TYPE is equal to COOKIE." |
| 65 | (with-syntax ((current-abi (current-abi-identifier type))) |
| 66 | #`(unless (eq? current-abi #,cookie) |
| 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" |
| 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))))))) |
| 97 | |
| 98 | (define-syntax-parameter this-record |
| 99 | (lambda (s) |
| 100 | "Return the record being defined. This macro may only be used in the |
| 101 | context 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 | |
| 109 | (define-syntax make-syntactic-constructor |
| 110 | (syntax-rules () |
| 111 | "Make the syntactic constructor NAME for TYPE, that calls CTOR, and |
| 112 | expects all of EXPECTED fields to be initialized. DEFAULTS is the list of |
| 113 | FIELD/DEFAULT-VALUE tuples, THUNKED is the list of identifiers of thunked |
| 114 | fields, and DELAYED is the list of identifiers of delayed fields. |
| 115 | |
| 116 | ABI-COOKIE is the cookie (an integer) against which to check the run-time ABI |
| 117 | of TYPE matches the expansion-time ABI." |
| 118 | ((_ type name ctor (expected ...) |
| 119 | #:abi-cookie abi-cookie |
| 120 | #:thunked thunked |
| 121 | #:this-identifier this-identifier |
| 122 | #:delayed delayed |
| 123 | #:innate innate |
| 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 | |
| 143 | #`(make-struct/no-tail type |
| 144 | #,@(map (lambda (field index) |
| 145 | (or (field-inherited-value field) |
| 146 | (if (innate-field? field) |
| 147 | (wrap-field-value |
| 148 | field (field-default-value field)) |
| 149 | #`(struct-ref #,orig-record |
| 150 | #,index)))) |
| 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 | |
| 160 | (define (innate-field? f) |
| 161 | (memq (syntax->datum f) 'innate)) |
| 162 | |
| 163 | (define (wrap-field-value f value) |
| 164 | (cond ((thunked-field? f) |
| 165 | #`(lambda (x) |
| 166 | (syntax-parameterize ((#,this-identifier |
| 167 | (lambda (s) |
| 168 | (syntax-case s () |
| 169 | (id |
| 170 | (identifier? #'id) |
| 171 | #'x))))) |
| 172 | #,value))) |
| 173 | ((delayed-field? f) |
| 174 | #`(delay #,value)) |
| 175 | (else value))) |
| 176 | |
| 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 | |
| 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) (... ...))) |
| 199 | #,(abi-check #'type abi-cookie) |
| 200 | #,(record-inheritance #'orig-record |
| 201 | #'((field value) (... ...))))) |
| 202 | ((_ (field value) (... ...)) |
| 203 | (let ((fields (map syntax->datum #'(field (... ...))))) |
| 204 | (define (field-value f) |
| 205 | (or (find (lambda (x) |
| 206 | (eq? f (syntax->datum x))) |
| 207 | #'(field (... ...))) |
| 208 | (wrap-field-value f (field-default-value f)))) |
| 209 | |
| 210 | ;; Pass S to make sure source location info is preserved. |
| 211 | (report-duplicate-field-specifier 'name s) |
| 212 | |
| 213 | (let ((fields (append fields (map car default-values)))) |
| 214 | (cond ((lset= eq? fields '(expected ...)) |
| 215 | #`(let* #,(field-bindings |
| 216 | #'((field value) (... ...))) |
| 217 | #,(abi-check #'type abi-cookie) |
| 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 ...) |
| 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 (... ...)))))))))) |
| 237 | |
| 238 | (define-syntax-rule (define-field-property-predicate predicate property) |
| 239 | "Define PREDICATE as a procedure that takes a syntax object and, when passed |
| 240 | a 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 | |
| 249 | (define-syntax define-record-type* |
| 250 | (lambda (s) |
| 251 | "Define the given record type such that an additional \"syntactic |
| 252 | constructor\" is defined, which allows instances to be constructed with named |
| 253 | field initializers, à la SRFI-35, as well as default values. An example use |
| 254 | may look like this: |
| 255 | |
| 256 | (define-record-type* <thing> thing make-thing |
| 257 | thing? |
| 258 | this-thing |
| 259 | (name thing-name (default \"chbouib\")) |
| 260 | (port thing-port |
| 261 | (default (current-output-port)) (thunked)) |
| 262 | (loc thing-location (innate) (default (current-source-location)))) |
| 263 | |
| 264 | This example defines a macro 'thing' that can be used to instantiate records |
| 265 | of this type: |
| 266 | |
| 267 | (thing |
| 268 | (name \"foo\") |
| 269 | (port (current-error-port))) |
| 270 | |
| 271 | The value of 'name' or 'port' could as well be omitted, in which case the |
| 272 | default value specified in the 'define-record-type*' form is used: |
| 273 | |
| 274 | (thing) |
| 275 | |
| 276 | The 'port' field is \"thunked\", meaning that calls like '(thing-port x)' will |
| 277 | actually compute the field's value in the current dynamic extent, which is |
| 278 | useful when referring to fluids in a field's value. Furthermore, that thunk |
| 279 | can access the record it belongs to via the 'this-thing' identifier. |
| 280 | |
| 281 | A field can also be marked as \"delayed\" instead of \"thunked\", in which |
| 282 | case its value is effectively wrapped in a (delay …) form. |
| 283 | |
| 284 | It is possible to copy an object 'x' created with 'thing' like this: |
| 285 | |
| 286 | (thing (inherit x) (name \"bar\")) |
| 287 | |
| 288 | This expression returns a new object equal to 'x' except for its 'name' |
| 289 | field and its 'loc' field---the latter is marked as \"innate\", so it is not |
| 290 | inherited." |
| 291 | |
| 292 | (define (field-default-value s) |
| 293 | (syntax-case s (default) |
| 294 | ((field (default val) _ ...) |
| 295 | (list #'field #'val)) |
| 296 | ((field _ properties ...) |
| 297 | (field-default-value #'(field properties ...))) |
| 298 | (_ #f))) |
| 299 | |
| 300 | (define-field-property-predicate delayed-field? delayed) |
| 301 | (define-field-property-predicate thunked-field? thunked) |
| 302 | (define-field-property-predicate innate-field? innate) |
| 303 | |
| 304 | (define (wrapped-field? s) |
| 305 | (or (thunked-field? s) (delayed-field? s))) |
| 306 | |
| 307 | (define (wrapped-field-accessor-name field) |
| 308 | ;; Return the name (an unhygienic syntax object) of the "real" |
| 309 | ;; getter for field, which is assumed to be a wrapped field. |
| 310 | (syntax-case field () |
| 311 | ((field get properties ...) |
| 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 () |
| 320 | ((name get properties ...) |
| 321 | #`(name |
| 322 | #,(if (wrapped-field? field) |
| 323 | (wrapped-field-accessor-name field) |
| 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 _ ...) |
| 331 | (with-syntax ((real-get (wrapped-field-accessor-name field))) |
| 332 | #'(define-inlinable (get x) |
| 333 | ;; The real value of that field is a thunk, so call it. |
| 334 | ((real-get x) x)))))) |
| 335 | |
| 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 | |
| 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 | |
| 356 | (syntax-case s () |
| 357 | ((_ type syntactic-ctor ctor pred |
| 358 | this-identifier |
| 359 | (field get properties ...) ...) |
| 360 | (identifier? #'this-identifier) |
| 361 | (let* ((field-spec #'((field get properties ...) ...)) |
| 362 | (thunked (filter-map thunked-field? field-spec)) |
| 363 | (delayed (filter-map delayed-field? field-spec)) |
| 364 | (innate (filter-map innate-field? field-spec)) |
| 365 | (defaults (filter-map field-default-value |
| 366 | #'((field properties ...) ...))) |
| 367 | (cookie (compute-abi-cookie field-spec))) |
| 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))) |
| 375 | field-spec)) |
| 376 | ((delayed-field-accessor ...) |
| 377 | (filter-map (lambda (field) |
| 378 | (and (delayed-field? field) |
| 379 | (delayed-field-accessor-definition |
| 380 | field))) |
| 381 | field-spec))) |
| 382 | #`(begin |
| 383 | (define-record-type type |
| 384 | (ctor field ...) |
| 385 | pred |
| 386 | field-spec* ...) |
| 387 | (define #,(current-abi-identifier #'type) |
| 388 | #,cookie) |
| 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 |
| 395 | only 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 \ |
| 401 | of a record instantiation" |
| 402 | #'id))))))) |
| 403 | thunked-field-accessor ... |
| 404 | delayed-field-accessor ... |
| 405 | (make-syntactic-constructor type syntactic-ctor ctor |
| 406 | (field ...) |
| 407 | #:abi-cookie #,cookie |
| 408 | #:thunked #,thunked |
| 409 | #:this-identifier #'this-identifier |
| 410 | #:delayed #,delayed |
| 411 | #:innate #,innate |
| 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 ...) ...))))) |
| 419 | |
| 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 |
| 423 | are also in MULTIPLE-VALUE-KEYS are considered to occur possibly multiple |
| 424 | times 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))) |
| 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 |
| 437 | PORT, 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 | |
| 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 #\%))) |
| 452 | |
| 453 | (define (recutils->alist port) |
| 454 | "Read a recutils-style record from PORT and return it as a list of key/value |
| 455 | pairs. Stop upon an empty line (after consuming it) or EOF." |
| 456 | (let loop ((line (read-line port)) |
| 457 | (result '())) |
| 458 | (cond ((eof-object? line) |
| 459 | (reverse result)) |
| 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 |
| 464 | (else |
| 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)))))))) |
| 488 | |
| 489 | (define-syntax match-record |
| 490 | (syntax-rules () |
| 491 | "Bind each FIELD of a RECORD of the given TYPE to it's FIELD name. |
| 492 | The 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 | |
| 504 | ;;; records.scm ends here |