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