guix/records.scm

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