guix/records.scm

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