guix/records.scm

   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