guix/records.scm

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