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