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