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