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