guix/records.scm

   1 ;;; GNU Guix --- Functional package management for GNU
   2 ;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020, 2021 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, DELAYED is the list of identifiers of delayed fields, and SANITIZERS
 124 is the list of FIELD/SANITIZER tuples.
 125
 126 ABI-COOKIE is the cookie (an integer) against which to check the run-time ABI
 127 of TYPE matches the expansion-time ABI."
 128     ((_ type name ctor (expected ...)
 129         #:abi-cookie abi-cookie
 130         #:thunked thunked
 131         #:this-identifier this-identifier
 132         #:delayed delayed
 133         #:innate innate
 134         #:sanitizers sanitizers
 135         #:defaults defaults)
 136      (define-syntax name
 137        (lambda (s)
 138          (define (record-inheritance orig-record field+value)
 139            ;; Produce code that returns a record identical to ORIG-RECORD,
 140            ;; except that values for the FIELD+VALUE alist prevail.
 141            (define (field-inherited-value f)
 142              (and=> (find (lambda (x)
 143                             (eq? f (car (syntax->datum x))))
 144                           field+value)
 145                     car))
 146
 147            ;; Make sure there are no unknown field names.
 148            (let* ((fields     (map (compose car syntax->datum) field+value))
 149                   (unexpected (lset-difference eq? fields '(expected ...))))
 150              (when (pair? unexpected)
 151                (record-error 'name s "extraneous field initializers ~a"
 152                              unexpected)))
 153
 154            #`(make-struct/no-tail type
 155                           #,@(map (lambda (field index)
 156                                     (or (field-inherited-value field)
 157                                         (if (innate-field? field)
 158                                             (wrap-field-value
 159                                              field (field-default-value field))
 160                                             #`(struct-ref #,orig-record
 161                                                           #,index))))
 162                                   '(expected ...)
 163                                   (iota (length '(expected ...))))))
 164
 165          (define (thunked-field? f)
 166            (memq (syntax->datum f) 'thunked))
 167
 168          (define (delayed-field? f)
 169            (memq (syntax->datum f) 'delayed))
 170
 171          (define (innate-field? f)
 172            (memq (syntax->datum f) 'innate))
 173
 174          (define field-sanitizer
 175            (let ((lst (map (match-lambda
 176                              ((f p)
 177                               (list (syntax->datum f) p)))
 178                            #'sanitizers)))
 179              (lambda (f)
 180                (or (and=> (assoc-ref lst (syntax->datum f)) car)
 181                    #'(lambda (x) x)))))
 182
 183          (define (wrap-field-value f value)
 184            (let* ((sanitizer (field-sanitizer f))
 185                   (value     #`(#,sanitizer #,value)))
 186              (cond ((thunked-field? f)
 187                     #`(lambda (x)
 188                         (syntax-parameterize ((#,this-identifier
 189                                                (lambda (s)
 190                                                  (syntax-case s ()
 191                                                    (id
 192                                                     (identifier? #'id)
 193                                                     #'x)))))
 194                           #,value)))
 195                    ((delayed-field? f)
 196                     #`(delay #,value))
 197                    (else value))))
 198
 199          (define default-values
 200            ;; List of symbol/value tuples.
 201            (map (match-lambda
 202                   ((f v)
 203                    (list (syntax->datum f) v)))
 204                 #'defaults))
 205
 206          (define (field-default-value f)
 207            (car (assoc-ref default-values (syntax->datum f))))
 208
 209          (define (field-bindings field+value)
 210            ;; Return field to value bindings, for use in 'let*' below.
 211            (map (lambda (field+value)
 212                   (syntax-case field+value ()
 213                     ((field value)
 214                      #`(field
 215                         #,(wrap-field-value #'field #'value)))))
 216                 field+value))
 217
 218          (syntax-case s (inherit expected ...)
 219            ((_ (inherit orig-record) (field value) (... ...))
 220             #`(let* #,(field-bindings #'((field value) (... ...)))
 221                 #,(abi-check #'type abi-cookie)
 222                 #,(record-inheritance #'orig-record
 223                                       #'((field value) (... ...)))))
 224            ((_ (field value) (... ...))
 225             (let ((fields (map syntax->datum #'(field (... ...)))))
 226               (define (field-value f)
 227                 (or (find (lambda (x)
 228                             (eq? f (syntax->datum x)))
 229                           #'(field (... ...)))
 230                     (wrap-field-value f (field-default-value f))))
 231
 232               ;; Pass S to make sure source location info is preserved.
 233               (report-duplicate-field-specifier 'name s)
 234
 235               (let ((fields (append fields (map car default-values))))
 236                 (cond ((lset= eq? fields '(expected ...))
 237                        #`(let* #,(field-bindings
 238                                   #'((field value) (... ...)))
 239                            #,(abi-check #'type abi-cookie)
 240                            (ctor #,@(map field-value '(expected ...)))))
 241                       ((pair? (lset-difference eq? fields
 242                                                '(expected ...)))
 243                        (record-error 'name s
 244                                      "extraneous field initializers ~a"
 245                                      (lset-difference eq? fields
 246                                                       '(expected ...))))
 247                       (else
 248                        (record-error 'name s
 249                                      "missing field initializers ~a"
 250                                      (lset-difference eq?
 251                                                       '(expected ...)
 252                                                       fields)))))))
 253            ((_ bindings (... ...))
 254             ;; One of BINDINGS doesn't match the (field value) pattern.
 255             ;; Report precisely which one is faulty, instead of letting the
 256             ;; "source expression failed to match any pattern" error.
 257             (report-invalid-field-specifier 'name
 258                                             #'(bindings (... ...))
 259                                             s))))))))
 260
 261 (define-syntax-rule (define-field-property-predicate predicate property)
 262   "Define PREDICATE as a procedure that takes a syntax object and, when passed
 263 a field specification, returns the field name if it has the given PROPERTY."
 264   (define (predicate s)
 265     (syntax-case s (property)
 266       ((field (property values (... ...)) _ (... ...))
 267        #'field)
 268       ((field _ properties (... ...))
 269        (predicate #'(field properties (... ...))))
 270       (_ #f))))
 271
 272 (define-syntax define-record-type*
 273   (lambda (s)
 274     "Define the given record type such that an additional \"syntactic
 275 constructor\" is defined, which allows instances to be constructed with named
 276 field initializers, à la SRFI-35, as well as default values.  An example use
 277 may look like this:
 278
 279   (define-record-type* <thing> thing make-thing
 280     thing?
 281     this-thing
 282     (name  thing-name (default \"chbouib\"))
 283     (port  thing-port
 284            (default (current-output-port)) (thunked))
 285     (loc   thing-location (innate) (default (current-source-location))))
 286
 287 This example defines a macro 'thing' that can be used to instantiate records
 288 of this type:
 289
 290   (thing
 291     (name \"foo\")
 292     (port (current-error-port)))
 293
 294 The value of 'name' or 'port' could as well be omitted, in which case the
 295 default value specified in the 'define-record-type*' form is used:
 296
 297   (thing)
 298
 299 The 'port' field is \"thunked\", meaning that calls like '(thing-port x)' will
 300 actually compute the field's value in the current dynamic extent, which is
 301 useful when referring to fluids in a field's value.  Furthermore, that thunk
 302 can access the record it belongs to via the 'this-thing' identifier.
 303
 304 A field can also be marked as \"delayed\" instead of \"thunked\", in which
 305 case its value is effectively wrapped in a (delay …) form.
 306
 307 A field can also have an associated \"sanitizer\", which is a procedure that
 308 takes a user-supplied field value and returns a \"sanitized\" value for the
 309 field:
 310
 311   (define-record-type* <thing> thing make-thing
 312     thing?
 313     this-thing
 314     (name  thing-name
 315            (sanitize (lambda (value)
 316                        (cond ((string? value) value)
 317                              ((symbol? value) (symbol->string value))
 318                              (else (throw 'bad! value)))))))
 319
 320 It is possible to copy an object 'x' created with 'thing' like this:
 321
 322   (thing (inherit x) (name \"bar\"))
 323
 324 This expression returns a new object equal to 'x' except for its 'name'
 325 field and its 'loc' field---the latter is marked as \"innate\", so it is not
 326 inherited."
 327
 328     (define (field-default-value s)
 329       (syntax-case s (default)
 330         ((field (default val) _ ...)
 331          (list #'field #'val))
 332         ((field _ properties ...)
 333          (field-default-value #'(field properties ...)))
 334         (_ #f)))
 335
 336     (define (field-sanitizer s)
 337       (syntax-case s (sanitize)
 338         ((field (sanitize proc) _ ...)
 339          (list #'field #'proc))
 340         ((field _ properties ...)
 341          (field-sanitizer #'(field properties ...)))
 342         (_ #f)))
 343
 344     (define-field-property-predicate delayed-field? delayed)
 345     (define-field-property-predicate thunked-field? thunked)
 346     (define-field-property-predicate innate-field? innate)
 347
 348     (define (wrapped-field? s)
 349       (or (thunked-field? s) (delayed-field? s)))
 350
 351     (define (wrapped-field-accessor-name field)
 352       ;; Return the name (an unhygienic syntax object) of the "real"
 353       ;; getter for field, which is assumed to be a wrapped field.
 354       (syntax-case field ()
 355         ((field get properties ...)
 356          (let* ((getter      (syntax->datum #'get))
 357                 (real-getter (symbol-append '% getter '-real)))
 358            (datum->syntax #'get real-getter)))))
 359
 360     (define (field-spec->srfi-9 field)
 361       ;; Convert a field spec of our style to a SRFI-9 field spec of the
 362       ;; form (field get).
 363       (syntax-case field ()
 364         ((name get properties ...)
 365          #`(name
 366             #,(if (wrapped-field? field)
 367                   (wrapped-field-accessor-name field)
 368                   #'get)))))
 369
 370     (define (thunked-field-accessor-definition field)
 371       ;; Return the real accessor for FIELD, which is assumed to be a
 372       ;; thunked field.
 373       (syntax-case field ()
 374         ((name get _ ...)
 375          (with-syntax ((real-get (wrapped-field-accessor-name field)))
 376            #'(define-inlinable (get x)
 377                ;; The real value of that field is a thunk, so call it.
 378                ((real-get x) x))))))
 379
 380     (define (delayed-field-accessor-definition field)
 381       ;; Return the real accessor for FIELD, which is assumed to be a
 382       ;; delayed field.
 383       (syntax-case field ()
 384         ((name get _ ...)
 385          (with-syntax ((real-get (wrapped-field-accessor-name field)))
 386            #'(define-inlinable (get x)
 387                ;; The real value of that field is a promise, so force it.
 388                (force (real-get x)))))))
 389
 390     (define (compute-abi-cookie field-specs)
 391       ;; Compute an "ABI cookie" for the given FIELD-SPECS.  We use
 392       ;; 'string-hash' because that's a better hash function that 'hash' on a
 393       ;; list of symbols.
 394       (syntax-case field-specs ()
 395         (((field get properties ...) ...)
 396          (string-hash (object->string
 397                        (syntax->datum #'((field properties ...) ...)))
 398                       (cond-expand
 399                         (guile-3 (target-most-positive-fixnum))
 400                         (else most-positive-fixnum))))))
 401
 402     (syntax-case s ()
 403       ((_ type syntactic-ctor ctor pred
 404           this-identifier
 405           (field get properties ...) ...)
 406        (identifier? #'this-identifier)
 407        (let* ((field-spec #'((field get properties ...) ...))
 408               (thunked    (filter-map thunked-field? field-spec))
 409               (delayed    (filter-map delayed-field? field-spec))
 410               (innate     (filter-map innate-field? field-spec))
 411               (defaults   (filter-map field-default-value
 412                                       #'((field properties ...) ...)))
 413               (sanitizers (filter-map field-sanitizer
 414                                         #'((field properties ...) ...)))
 415               (cookie     (compute-abi-cookie field-spec)))
 416          (with-syntax (((field-spec* ...)
 417                         (map field-spec->srfi-9 field-spec))
 418                        ((thunked-field-accessor ...)
 419                         (filter-map (lambda (field)
 420                                       (and (thunked-field? field)
 421                                            (thunked-field-accessor-definition
 422                                             field)))
 423                                     field-spec))
 424                        ((delayed-field-accessor ...)
 425                         (filter-map (lambda (field)
 426                                       (and (delayed-field? field)
 427                                            (delayed-field-accessor-definition
 428                                             field)))
 429                                     field-spec)))
 430            #`(begin
 431                (define-record-type type
 432                  (ctor field ...)
 433                  pred
 434                  field-spec* ...)
 435                (define #,(current-abi-identifier #'type)
 436                  #,cookie)
 437
 438                #,@(if (free-identifier=? #'this-identifier #'this-record)
 439                       #'()
 440                       #'((define-syntax-parameter this-identifier
 441                            (lambda (s)
 442                              "Return the record being defined.  This macro may
 443 only be used in the context of the definition of a thunked field."
 444                              (syntax-case s ()
 445                                (id
 446                                 (identifier? #'id)
 447                                 (syntax-violation 'this-identifier
 448                                                   "cannot be used outside \
 449 of a record instantiation"
 450                                                   #'id)))))))
 451                thunked-field-accessor ...
 452                delayed-field-accessor ...
 453                (make-syntactic-constructor type syntactic-ctor ctor
 454                                            (field ...)
 455                                            #:abi-cookie #,cookie
 456                                            #:thunked #,thunked
 457                                            #:this-identifier #'this-identifier
 458                                            #:delayed #,delayed
 459                                            #:innate #,innate
 460                                            #:sanitizers #,sanitizers
 461                                            #:defaults #,defaults)))))
 462       ((_ type syntactic-ctor ctor pred
 463           (field get properties ...) ...)
 464        ;; When no 'this' identifier was specified, use 'this-record'.
 465        #'(define-record-type* type syntactic-ctor ctor pred
 466            this-record
 467            (field get properties ...) ...)))))
 468
 469 (define* (alist->record alist make keys
 470                         #:optional (multiple-value-keys '()))
 471   "Apply MAKE to the values associated with KEYS in ALIST.  Items in KEYS that
 472 are also in MULTIPLE-VALUE-KEYS are considered to occur possibly multiple
 473 times in ALIST, and thus their value is a list."
 474   (let ((args (map (lambda (key)
 475                      (if (member key multiple-value-keys)
 476                          (filter-map (match-lambda
 477                                       ((k . v)
 478                                        (and (equal? k key) v)))
 479                                      alist)
 480                          (assoc-ref alist key)))
 481                    keys)))
 482     (apply make args)))
 483
 484 (define (object->fields object fields port)
 485   "Write OBJECT (typically a record) as a series of recutils-style fields to
 486 PORT, according to FIELDS.  FIELDS must be a list of field name/getter pairs."
 487   (let loop ((fields fields))
 488     (match fields
 489       (()
 490        object)
 491       (((field . get) rest ...)
 492        (format port "~a: ~a~%" field (get object))
 493        (loop rest)))))
 494
 495 (define %recutils-field-charset
 496   ;; Valid characters starting a recutils field.
 497   ;; info "(recutils) Fields"
 498   (char-set-union char-set:upper-case
 499                   char-set:lower-case
 500                   (char-set #\%)))
 501
 502 (define (recutils->alist port)
 503   "Read a recutils-style record from PORT and return it as a list of key/value
 504 pairs.  Stop upon an empty line (after consuming it) or EOF."
 505   (let loop ((line   (read-line port))
 506              (result '()))
 507     (cond ((eof-object? line)
 508            (reverse result))
 509           ((string-null? line)
 510            (if (null? result)
 511                (loop (read-line port) result)     ; leading space: ignore it
 512                (reverse result)))                 ; end-of-record marker
 513           (else
 514            ;; Now check the first character of LINE, since that's what the
 515            ;; recutils manual says is enough.
 516            (let ((first (string-ref line 0)))
 517              (cond
 518               ((char-set-contains? %recutils-field-charset first)
 519                (let* ((colon (string-index line #\:))
 520                       (field (string-take line colon))
 521                       (value (string-trim (string-drop line (+ 1 colon)))))
 522                  (loop (read-line port)
 523                        (alist-cons field value result))))
 524               ((eqv? first #\#)                   ;info "(recutils) Comments"
 525                (loop (read-line port) result))
 526               ((eqv? first #\+)                   ;info "(recutils) Fields"
 527                (let ((new-line (if (string-prefix? "+ " line)
 528                                    (string-drop line 2)
 529                                    (string-drop line 1))))
 530                 (match result
 531                   (((field . value) rest ...)
 532                    (loop (read-line port)
 533                          `((,field . ,(string-append value "\n" new-line))
 534                            ,@rest))))))
 535               (else
 536                (error "unmatched line" line))))))))
 537
 538 (define-syntax match-record
 539   (syntax-rules ()
 540     "Bind each FIELD of a RECORD of the given TYPE to it's FIELD name.
 541 The current implementation does not support thunked and delayed fields."
 542     ((_ record type (field fields ...) body ...)
 543      (if (eq? (struct-vtable record) type)
 544          ;; TODO compute indices and report wrong-field-name errors at
 545          ;;      expansion time
 546          ;; TODO support thunked and delayed fields
 547          (let ((field ((record-accessor type 'field) record)))
 548            (match-record record type (fields ...) body ...))
 549          (throw 'wrong-type-arg record)))
 550     ((_ record type () body ...)
 551      (begin body ...))))
 552
 553 ;;; records.scm ends here