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