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