guix/records.scm

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