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