[jackhill/guix/guix.git] / guix / records.scm

;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017 Ludovic Courtès <ludo@gnu.org>
;;;
;;; This file is part of GNU Guix.
;;;
;;; GNU Guix is free software; you can redistribute it and/or modify it
;;; under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 3 of the License, or (at
;;; your option) any later version.
;;;
;;; GNU Guix is distributed in the hope that it will be useful, but
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;; GNU General Public License for more details.
;;;
;;; You should have received a copy of the GNU General Public License
;;; along with GNU Guix.  If not, see <http://www.gnu.org/licenses/>.

(define-module (guix records)
  #:use-module (srfi srfi-1)
  #:use-module (srfi srfi-9)
  #:use-module (srfi srfi-26)
  #:use-module (ice-9 match)
  #:use-module (ice-9 regex)
  #:use-module (ice-9 rdelim)
  #:export (define-record-type*
            alist->record
            object->fields
            recutils->alist
            match-record))

;;; Commentary:
;;;
;;; Utilities for dealing with Scheme records.
;;;
;;; Code:

(define-syntax record-error
  (syntax-rules ()
    "Report a syntactic error in use of CONSTRUCTOR."
    ((_ constructor form fmt args ...)
     (syntax-violation constructor
                       (format #f fmt args ...)
                       form))))

(define (report-invalid-field-specifier name bindings)
  "Report the first invalid binding among BINDINGS."
  (let loop ((bindings bindings))
    (syntax-case bindings ()
      (((field value) rest ...)                   ;good
       (loop #'(rest ...)))
      ((weird _ ...)                              ;weird!
       (syntax-violation name "invalid field specifier" #'weird)))))

(define-syntax make-syntactic-constructor
  (syntax-rules ()
    "Make the syntactic constructor NAME for TYPE, that calls CTOR, and
expects all of EXPECTED fields to be initialized.  DEFAULTS is the list of
FIELD/DEFAULT-VALUE tuples, THUNKED is the list of identifiers of thunked
fields, and DELAYED is the list of identifiers of delayed fields."
    ((_ type name ctor (expected ...)
        #:thunked thunked
        #:delayed delayed
        #:innate innate
        #:defaults defaults)
     (define-syntax name
       (lambda (s)
         (define (record-inheritance orig-record field+value)
           ;; Produce code that returns a record identical to ORIG-RECORD,
           ;; except that values for the FIELD+VALUE alist prevail.
           (define (field-inherited-value f)
             (and=> (find (lambda (x)
                            (eq? f (car (syntax->datum x))))
                          field+value)
                    car))

           ;; Make sure there are no unknown field names.
           (let* ((fields     (map (compose car syntax->datum) field+value))
                  (unexpected (lset-difference eq? fields '(expected ...))))
             (when (pair? unexpected)
               (record-error 'name s "extraneous field initializers ~a"
                             unexpected)))

           #`(make-struct/no-tail type
                          #,@(map (lambda (field index)
                                    (or (field-inherited-value field)
                                        (if (innate-field? field)
                                            (wrap-field-value
                                             field (field-default-value field))
                                            #`(struct-ref #,orig-record
                                                          #,index))))
                                  '(expected ...)
                                  (iota (length '(expected ...))))))

         (define (thunked-field? f)
           (memq (syntax->datum f) 'thunked))

         (define (delayed-field? f)
           (memq (syntax->datum f) 'delayed))

         (define (innate-field? f)
           (memq (syntax->datum f) 'innate))

         (define (wrap-field-value f value)
           (cond ((thunked-field? f)
                  #`(lambda () #,value))
                 ((delayed-field? f)
                  #`(delay #,value))
                 (else value)))

         (define default-values
           ;; List of symbol/value tuples.
           (map (match-lambda
                  ((f v)
                   (list (syntax->datum f) v)))
                #'defaults))

         (define (field-default-value f)
           (car (assoc-ref default-values (syntax->datum f))))

         (define (field-bindings field+value)
           ;; Return field to value bindings, for use in 'let*' below.
           (map (lambda (field+value)
                  (syntax-case field+value ()
                    ((field value)
                     #`(field
                        #,(wrap-field-value #'field #'value)))))
                field+value))

         (syntax-case s (inherit expected ...)
           ((_ (inherit orig-record) (field value) (... ...))
            #`(let* #,(field-bindings #'((field value) (... ...)))
                #,(record-inheritance #'orig-record
                                      #'((field value) (... ...)))))
           ((_ (field value) (... ...))
            (let ((fields (map syntax->datum #'(field (... ...)))))
              (define (field-value f)
                (or (find (lambda (x)
                            (eq? f (syntax->datum x)))
                          #'(field (... ...)))
                    (wrap-field-value f (field-default-value f))))

              (let ((fields (append fields (map car default-values))))
                (cond ((lset= eq? fields '(expected ...))
                       #`(let* #,(field-bindings
                                  #'((field value) (... ...)))
                           (ctor #,@(map field-value '(expected ...)))))
                      ((pair? (lset-difference eq? fields
                                               '(expected ...)))
                       (record-error 'name s
                                     "extraneous field initializers ~a"
                                     (lset-difference eq? fields
                                                      '(expected ...))))
                      (else
                       (record-error 'name s
                                     "missing field initializers ~a"
                                     (lset-difference eq?
                                                      '(expected ...)
                                                      fields)))))))
           ((_ bindings (... ...))
            ;; One of BINDINGS doesn't match the (field value) pattern.
            ;; Report precisely which one is faulty, instead of letting the
            ;; "source expression failed to match any pattern" error.
            (report-invalid-field-specifier 'name
                                            #'(bindings (... ...))))))))))

(define-syntax-rule (define-field-property-predicate predicate property)
  "Define PREDICATE as a procedure that takes a syntax object and, when passed
a field specification, returns the field name if it has the given PROPERTY."
  (define (predicate s)
    (syntax-case s (property)
      ((field (property values (... ...)) _ (... ...))
       #'field)
      ((field _ properties (... ...))
       (predicate #'(field properties (... ...))))
      (_ #f))))

(define-syntax define-record-type*
  (lambda (s)
    "Define the given record type such that an additional \"syntactic
constructor\" is defined, which allows instances to be constructed with named
field initializers, à la SRFI-35, as well as default values.  An example use
may look like this:

  (define-record-type* <thing> thing make-thing
    thing?
    (name  thing-name (default \"chbouib\"))
    (port  thing-port
           (default (current-output-port)) (thunked))
    (loc   thing-location (innate) (default (current-source-location))))

This example defines a macro 'thing' that can be used to instantiate records
of this type:

  (thing
    (name \"foo\")
    (port (current-error-port)))

The value of 'name' or 'port' could as well be omitted, in which case the
default value specified in the 'define-record-type*' form is used:

  (thing)

The 'port' field is \"thunked\", meaning that calls like '(thing-port x)' will
actually compute the field's value in the current dynamic extent, which is
useful when referring to fluids in a field's value.

A field can also be marked as \"delayed\" instead of \"thunked\", in which
case its value is effectively wrapped in a (delay …) form.

It is possible to copy an object 'x' created with 'thing' like this:

  (thing (inherit x) (name \"bar\"))

This expression returns a new object equal to 'x' except for its 'name'
field and its 'loc' field---the latter is marked as \"innate\", so it is not
inherited."

    (define (field-default-value s)
      (syntax-case s (default)
        ((field (default val) _ ...)
         (list #'field #'val))
        ((field _ properties ...)
         (field-default-value #'(field properties ...)))
        (_ #f)))

    (define-field-property-predicate delayed-field? delayed)
    (define-field-property-predicate thunked-field? thunked)
    (define-field-property-predicate innate-field? innate)

    (define (wrapped-field? s)
      (or (thunked-field? s) (delayed-field? s)))

    (define (wrapped-field-accessor-name field)
      ;; Return the name (an unhygienic syntax object) of the "real"
      ;; getter for field, which is assumed to be a wrapped field.
      (syntax-case field ()
        ((field get properties ...)
         (let* ((getter      (syntax->datum #'get))
                (real-getter (symbol-append '% getter '-real)))
           (datum->syntax #'get real-getter)))))

    (define (field-spec->srfi-9 field)
      ;; Convert a field spec of our style to a SRFI-9 field spec of the
      ;; form (field get).
      (syntax-case field ()
        ((name get properties ...)
         #`(name
            #,(if (wrapped-field? field)
                  (wrapped-field-accessor-name field)
                  #'get)))))

    (define (thunked-field-accessor-definition field)
      ;; Return the real accessor for FIELD, which is assumed to be a
      ;; thunked field.
      (syntax-case field ()
        ((name get _ ...)
         (with-syntax ((real-get (wrapped-field-accessor-name field)))
           #'(define-inlinable (get x)
               ;; The real value of that field is a thunk, so call it.
               ((real-get x)))))))

    (define (delayed-field-accessor-definition field)
      ;; Return the real accessor for FIELD, which is assumed to be a
      ;; delayed field.
      (syntax-case field ()
        ((name get _ ...)
         (with-syntax ((real-get (wrapped-field-accessor-name field)))
           #'(define-inlinable (get x)
               ;; The real value of that field is a promise, so force it.
               (force (real-get x)))))))

    (syntax-case s ()
      ((_ type syntactic-ctor ctor pred
          (field get properties ...) ...)
       (let* ((field-spec #'((field get properties ...) ...))
              (thunked    (filter-map thunked-field? field-spec))
              (delayed    (filter-map delayed-field? field-spec))
              (innate     (filter-map innate-field? field-spec))
              (defaults   (filter-map field-default-value
                                      #'((field properties ...) ...))))
         (with-syntax (((field-spec* ...)
                        (map field-spec->srfi-9 field-spec))
                       ((thunked-field-accessor ...)
                        (filter-map (lambda (field)
                                      (and (thunked-field? field)
                                           (thunked-field-accessor-definition
                                            field)))
                                    field-spec))
                       ((delayed-field-accessor ...)
                        (filter-map (lambda (field)
                                      (and (delayed-field? field)
                                           (delayed-field-accessor-definition
                                            field)))
                                    field-spec)))
           #`(begin
               (define-record-type type
                 (ctor field ...)
                 pred
                 field-spec* ...)
               thunked-field-accessor ...
               delayed-field-accessor ...
               (make-syntactic-constructor type syntactic-ctor ctor
                                           (field ...)
                                           #:thunked #,thunked
                                           #:delayed #,delayed
                                           #:innate #,innate
                                           #:defaults #,defaults))))))))

(define* (alist->record alist make keys
                        #:optional (multiple-value-keys '()))
  "Apply MAKE to the values associated with KEYS in ALIST.  Items in KEYS that
are also in MULTIPLE-VALUE-KEYS are considered to occur possibly multiple
times in ALIST, and thus their value is a list."
  (let ((args (map (lambda (key)
                     (if (member key multiple-value-keys)
                         (filter-map (match-lambda
                                      ((k . v)
                                       (and (equal? k key) v)))
                                     alist)
                         (assoc-ref alist key)))
                   keys)))
    (apply make args)))

(define (object->fields object fields port)
  "Write OBJECT (typically a record) as a series of recutils-style fields to
PORT, according to FIELDS.  FIELDS must be a list of field name/getter pairs."
  (let loop ((fields fields))
    (match fields
      (()
       object)
      (((field . get) rest ...)
       (format port "~a: ~a~%" field (get object))
       (loop rest)))))

(define %recutils-field-charset
  ;; Valid characters starting a recutils field.
  ;; info "(recutils) Fields"
  (char-set-union char-set:upper-case
                  char-set:lower-case
                  (char-set #\%)))

(define (recutils->alist port)
  "Read a recutils-style record from PORT and return it as a list of key/value
pairs.  Stop upon an empty line (after consuming it) or EOF."
  (let loop ((line   (read-line port))
             (result '()))
    (cond ((eof-object? line)
           (reverse result))
          ((string-null? line)
           (if (null? result)
               (loop (read-line port) result)     ; leading space: ignore it
               (reverse result)))                 ; end-of-record marker
          (else
           ;; Now check the first character of LINE, since that's what the
           ;; recutils manual says is enough.
           (let ((first (string-ref line 0)))
             (cond
              ((char-set-contains? %recutils-field-charset first)
               (let* ((colon (string-index line #\:))
                      (field (string-take line colon))
                      (value (string-trim (string-drop line (+ 1 colon)))))
                 (loop (read-line port)
                       (alist-cons field value result))))
              ((eqv? first #\#)                   ;info "(recutils) Comments"
               (loop (read-line port) result))
              ((eqv? first #\+)                   ;info "(recutils) Fields"
               (let ((new-line (if (string-prefix? "+ " line)
                                   (string-drop line 2)
                                   (string-drop line 1))))
                (match result
                  (((field . value) rest ...)
                   (loop (read-line port)
                         `((,field . ,(string-append value "\n" new-line))
                           ,@rest))))))
              (else
               (error "unmatched line" line))))))))

(define-syntax match-record
  (syntax-rules ()
    "Bind each FIELD of a RECORD of the given TYPE to it's FIELD name.
The current implementation does not support thunked and delayed fields."
    ((_ record type (field fields ...) body ...)
     (if (eq? (struct-vtable record) type)
         ;; TODO compute indices and report wrong-field-name errors at
         ;;      expansion time
         ;; TODO support thunked and delayed fields
         (let ((field ((record-accessor type 'field) record)))
           (match-record record type (fields ...) body ...))
         (throw 'wrong-type-arg record)))
    ((_ record type () body ...)
     (begin body ...))))

;;; records.scm ends here
Commit	Line	Data
c0cd1b3e	1	;;; GNU Guix --- Functional package management for GNU
94df39cc	2	;;; Copyright © 2012, 2013, 2014, 2015, 2016, 2017 Ludovic Courtès <ludo@gnu.org>
c0cd1b3e LC	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)
fdc1bf65 LC	24	#:use-module (ice-9 regex)
fdc1bf65 LC	25	#:use-module (ice-9 rdelim)
c0cd1b3e LC	26	#:export (define-record-type*
c0cd1b3e LC	27	alist->record
fdc1bf65	28	object->fields
6692d845	29	recutils->alist
6692d845	30	match-record))
c0cd1b3e LC	31
	32	;;; Commentary:
	33	;;;
	34	;;; Utilities for dealing with Scheme records.
	35	;;;
	36	;;; Code:
	37
b1353e7a LC	38	(define-syntax record-error
	39	(syntax-rules ()
	40	"Report a syntactic error in use of CONSTRUCTOR."
	41	((_ constructor form fmt args ...)
	42	(syntax-violation constructor
	43	(format #f fmt args ...)
	44	form))))
	45
babc2c80 LC	46	(define (report-invalid-field-specifier name bindings)
	47	"Report the first invalid binding among BINDINGS."
	48	(let loop ((bindings bindings))
	49	(syntax-case bindings ()
	50	(((field value) rest ...) ;good
	51	(loop #'(rest ...)))
	52	((weird _ ...) ;weird!
	53	(syntax-violation name "invalid field specifier" #'weird)))))
	54
39fc041a LC	55	(define-syntax make-syntactic-constructor
	56	(syntax-rules ()
	57	"Make the syntactic constructor NAME for TYPE, that calls CTOR, and
	58	expects all of EXPECTED fields to be initialized. DEFAULTS is the list of
	59	FIELD/DEFAULT-VALUE tuples, THUNKED is the list of identifiers of thunked
	60	fields, and DELAYED is the list of identifiers of delayed fields."
	61	((_ type name ctor (expected ...)
	62	#:thunked thunked
	63	#:delayed delayed
8a16d064	64	#:innate innate
39fc041a LC	65	#:defaults defaults)
	66	(define-syntax name
	67	(lambda (s)
	68	(define (record-inheritance orig-record field+value)
	69	;; Produce code that returns a record identical to ORIG-RECORD,
	70	;; except that values for the FIELD+VALUE alist prevail.
	71	(define (field-inherited-value f)
	72	(and=> (find (lambda (x)
	73	(eq? f (car (syntax->datum x))))
	74	field+value)
	75	car))
	76
	77	;; Make sure there are no unknown field names.
	78	(let* ((fields (map (compose car syntax->datum) field+value))
	79	(unexpected (lset-difference eq? fields '(expected ...))))
	80	(when (pair? unexpected)
	81	(record-error 'name s "extraneous field initializers ~a"
	82	unexpected)))
	83
cea25b08	84	#`(make-struct/no-tail type
39fc041a LC	85	#,@(map (lambda (field index)
39fc041a LC	86	(or (field-inherited-value field)
8a16d064 LC	87	(if (innate-field? field)
	88	(wrap-field-value
	89	field (field-default-value field))
	90	#`(struct-ref #,orig-record
	91	#,index))))
39fc041a LC	92	'(expected ...)
	93	(iota (length '(expected ...))))))
	94
	95	(define (thunked-field? f)
	96	(memq (syntax->datum f) 'thunked))
	97
	98	(define (delayed-field? f)
	99	(memq (syntax->datum f) 'delayed))
	100
8a16d064 LC	101	(define (innate-field? f)
	102	(memq (syntax->datum f) 'innate))
	103
39fc041a LC	104	(define (wrap-field-value f value)
	105	(cond ((thunked-field? f)
	106	#`(lambda () #,value))
	107	((delayed-field? f)
	108	#`(delay #,value))
	109	(else value)))
	110
b9c86473 LC	111	(define default-values
	112	;; List of symbol/value tuples.
	113	(map (match-lambda
	114	((f v)
	115	(list (syntax->datum f) v)))
	116	#'defaults))
	117
	118	(define (field-default-value f)
	119	(car (assoc-ref default-values (syntax->datum f))))
	120
39fc041a LC	121	(define (field-bindings field+value)
	122	;; Return field to value bindings, for use in 'let*' below.
	123	(map (lambda (field+value)
	124	(syntax-case field+value ()
	125	((field value)
	126	#`(field
	127	#,(wrap-field-value #'field #'value)))))
	128	field+value))
	129
	130	(syntax-case s (inherit expected ...)
	131	((_ (inherit orig-record) (field value) (... ...))
	132	#`(let* #,(field-bindings #'((field value) (... ...)))
	133	#,(record-inheritance #'orig-record
	134	#'((field value) (... ...)))))
	135	((_ (field value) (... ...))
b9c86473	136	(let ((fields (map syntax->datum #'(field (... ...)))))
39fc041a	137	(define (field-value f)
94df39cc LC	138	(or (find (lambda (x)
	139	(eq? f (syntax->datum x)))
	140	#'(field (... ...)))
b9c86473	141	(wrap-field-value f (field-default-value f))))
39fc041a	142
b9c86473	143	(let ((fields (append fields (map car default-values))))
39fc041a LC	144	(cond ((lset= eq? fields '(expected ...))
	145	#`(let* #,(field-bindings
	146	#'((field value) (... ...)))
	147	(ctor #,@(map field-value '(expected ...)))))
	148	((pair? (lset-difference eq? fields
	149	'(expected ...)))
	150	(record-error 'name s
	151	"extraneous field initializers ~a"
	152	(lset-difference eq? fields
	153	'(expected ...))))
	154	(else
	155	(record-error 'name s
	156	"missing field initializers ~a"
	157	(lset-difference eq?
	158	'(expected ...)
babc2c80 LC	159	fields)))))))
	160	((_ bindings (... ...))
	161	;; One of BINDINGS doesn't match the (field value) pattern.
	162	;; Report precisely which one is faulty, instead of letting the
	163	;; "source expression failed to match any pattern" error.
	164	(report-invalid-field-specifier 'name
	165	#'(bindings (... ...))))))))))
cf4efb39	166
faef3b6a LC	167	(define-syntax-rule (define-field-property-predicate predicate property)
	168	"Define PREDICATE as a procedure that takes a syntax object and, when passed
	169	a field specification, returns the field name if it has the given PROPERTY."
	170	(define (predicate s)
	171	(syntax-case s (property)
	172	((field (property values (... ...)) _ (... ...))
	173	#'field)
	174	((field _ properties (... ...))
	175	(predicate #'(field properties (... ...))))
	176	(_ #f))))
	177
c0cd1b3e LC	178	(define-syntax define-record-type*
	179	(lambda (s)
	180	"Define the given record type such that an additional \"syntactic
	181	constructor\" is defined, which allows instances to be constructed with named
e2540884 LC	182	field initializers, à la SRFI-35, as well as default values. An example use
	183	may look like this:
	184
	185	(define-record-type* <thing> thing make-thing
	186	thing?
	187	(name thing-name (default \"chbouib\"))
	188	(port thing-port
8a16d064 LC	189	(default (current-output-port)) (thunked))
8a16d064 LC	190	(loc thing-location (innate) (default (current-source-location))))
e2540884 LC	191
	192	This example defines a macro 'thing' that can be used to instantiate records
	193	of this type:
	194
	195	(thing
	196	(name \"foo\")
	197	(port (current-error-port)))
	198
	199	The value of 'name' or 'port' could as well be omitted, in which case the
	200	default value specified in the 'define-record-type*' form is used:
	201
	202	(thing)
	203
	204	The 'port' field is \"thunked\", meaning that calls like '(thing-port x)' will
	205	actually compute the field's value in the current dynamic extent, which is
	206	useful when referring to fluids in a field's value.
	207
310b32a2 LC	208	A field can also be marked as \"delayed\" instead of \"thunked\", in which
	209	case its value is effectively wrapped in a (delay …) form.
	210
e2540884 LC	211	It is possible to copy an object 'x' created with 'thing' like this:
	212
	213	(thing (inherit x) (name \"bar\"))
	214
	215	This expression returns a new object equal to 'x' except for its 'name'
8a16d064 LC	216	field and its 'loc' field---the latter is marked as \"innate\", so it is not
8a16d064 LC	217	inherited."
e2540884	218
c0cd1b3e LC	219	(define (field-default-value s)
	220	(syntax-case s (default)
	221	((field (default val) _ ...)
	222	(list #'field #'val))
792798f4 LC	223	((field _ properties ...)
792798f4 LC	224	(field-default-value #'(field properties ...)))
c0cd1b3e LC	225	(_ #f)))
c0cd1b3e LC	226
faef3b6a LC	227	(define-field-property-predicate delayed-field? delayed)
faef3b6a LC	228	(define-field-property-predicate thunked-field? thunked)
8a16d064	229	(define-field-property-predicate innate-field? innate)
c0cd1b3e	230
310b32a2 LC	231	(define (wrapped-field? s)
	232	(or (thunked-field? s) (delayed-field? s)))
	233
	234	(define (wrapped-field-accessor-name field)
c0cd1b3e	235	;; Return the name (an unhygienic syntax object) of the "real"
310b32a2	236	;; getter for field, which is assumed to be a wrapped field.
c0cd1b3e	237	(syntax-case field ()
792798f4	238	((field get properties ...)
c0cd1b3e LC	239	(let* ((getter (syntax->datum #'get))
	240	(real-getter (symbol-append '% getter '-real)))
	241	(datum->syntax #'get real-getter)))))
	242
	243	(define (field-spec->srfi-9 field)
	244	;; Convert a field spec of our style to a SRFI-9 field spec of the
	245	;; form (field get).
	246	(syntax-case field ()
792798f4	247	((name get properties ...)
c0cd1b3e	248	#`(name
310b32a2 LC	249	#,(if (wrapped-field? field)
310b32a2 LC	250	(wrapped-field-accessor-name field)
c0cd1b3e LC	251	#'get)))))
	252
	253	(define (thunked-field-accessor-definition field)
	254	;; Return the real accessor for FIELD, which is assumed to be a
	255	;; thunked field.
	256	(syntax-case field ()
	257	((name get _ ...)
310b32a2	258	(with-syntax ((real-get (wrapped-field-accessor-name field)))
c0cd1b3e LC	259	#'(define-inlinable (get x)
	260	;; The real value of that field is a thunk, so call it.
	261	((real-get x)))))))
	262
310b32a2 LC	263	(define (delayed-field-accessor-definition field)
	264	;; Return the real accessor for FIELD, which is assumed to be a
	265	;; delayed field.
	266	(syntax-case field ()
	267	((name get _ ...)
	268	(with-syntax ((real-get (wrapped-field-accessor-name field)))
	269	#'(define-inlinable (get x)
	270	;; The real value of that field is a promise, so force it.
	271	(force (real-get x)))))))
	272
c0cd1b3e LC	273	(syntax-case s ()
c0cd1b3e LC	274	((_ type syntactic-ctor ctor pred
792798f4 LC	275	(field get properties ...) ...)
792798f4 LC	276	(let* ((field-spec #'((field get properties ...) ...))
9b543456	277	(thunked (filter-map thunked-field? field-spec))
310b32a2	278	(delayed (filter-map delayed-field? field-spec))
8a16d064	279	(innate (filter-map innate-field? field-spec))
9b543456	280	(defaults (filter-map field-default-value
792798f4	281	#'((field properties ...) ...))))
c0cd1b3e LC	282	(with-syntax (((field-spec* ...)
	283	(map field-spec->srfi-9 field-spec))
	284	((thunked-field-accessor ...)
	285	(filter-map (lambda (field)
	286	(and (thunked-field? field)
	287	(thunked-field-accessor-definition
	288	field)))
310b32a2 LC	289	field-spec))
	290	((delayed-field-accessor ...)
	291	(filter-map (lambda (field)
	292	(and (delayed-field? field)
	293	(delayed-field-accessor-definition
	294	field)))
c0cd1b3e LC	295	field-spec)))
	296	#`(begin
	297	(define-record-type type
	298	(ctor field ...)
	299	pred
	300	field-spec* ...)
ad7c1a2c LC	301	thunked-field-accessor ...
ad7c1a2c LC	302	delayed-field-accessor ...
39fc041a LC	303	(make-syntactic-constructor type syntactic-ctor ctor
	304	(field ...)
	305	#:thunked #,thunked
	306	#:delayed #,delayed
8a16d064	307	#:innate #,innate
39fc041a	308	#:defaults #,defaults))))))))
c0cd1b3e	309
c8772a7a LC	310	(define* (alist->record alist make keys
	311	#:optional (multiple-value-keys '()))
	312	"Apply MAKE to the values associated with KEYS in ALIST. Items in KEYS that
	313	are also in MULTIPLE-VALUE-KEYS are considered to occur possibly multiple
	314	times in ALIST, and thus their value is a list."
	315	(let ((args (map (lambda (key)
	316	(if (member key multiple-value-keys)
	317	(filter-map (match-lambda
	318	((k . v)
	319	(and (equal? k key) v)))
	320	alist)
	321	(assoc-ref alist key)))
	322	keys)))
c0cd1b3e LC	323	(apply make args)))
	324
	325	(define (object->fields object fields port)
	326	"Write OBJECT (typically a record) as a series of recutils-style fields to
	327	PORT, according to FIELDS. FIELDS must be a list of field name/getter pairs."
	328	(let loop ((fields fields))
	329	(match fields
	330	(()
	331	object)
	332	(((field . get) rest ...)
	333	(format port "~a: ~a~%" field (get object))
	334	(loop rest)))))
	335
fb519bd8 LC	336	(define %recutils-field-charset
	337	;; Valid characters starting a recutils field.
	338	;; info "(recutils) Fields"
	339	(char-set-union char-set:upper-case
	340	char-set:lower-case
	341	(char-set #\%)))
836d10f1	342
fdc1bf65 LC	343	(define (recutils->alist port)
	344	"Read a recutils-style record from PORT and return it as a list of key/value
	345	pairs. Stop upon an empty line (after consuming it) or EOF."
	346	(let loop ((line (read-line port))
	347	(result '()))
b7b88288	348	(cond ((eof-object? line)
fdc1bf65	349	(reverse result))
b7b88288 LC	350	((string-null? line)
	351	(if (null? result)
	352	(loop (read-line port) result) ; leading space: ignore it
	353	(reverse result))) ; end-of-record marker
fdc1bf65	354	(else
fb519bd8 LC	355	;; Now check the first character of LINE, since that's what the
	356	;; recutils manual says is enough.
	357	(let ((first (string-ref line 0)))
	358	(cond
	359	((char-set-contains? %recutils-field-charset first)
	360	(let* ((colon (string-index line #\:))
	361	(field (string-take line colon))
	362	(value (string-trim (string-drop line (+ 1 colon)))))
	363	(loop (read-line port)
	364	(alist-cons field value result))))
	365	((eqv? first #\#) ;info "(recutils) Comments"
	366	(loop (read-line port) result))
	367	((eqv? first #\+) ;info "(recutils) Fields"
	368	(let ((new-line (if (string-prefix? "+ " line)
	369	(string-drop line 2)
	370	(string-drop line 1))))
	371	(match result
	372	(((field . value) rest ...)
	373	(loop (read-line port)
	374	`((,field . ,(string-append value "\n" new-line))
	375	,@rest))))))
	376	(else
	377	(error "unmatched line" line))))))))
fdc1bf65	378
6692d845	379	(define-syntax match-record
	380	(syntax-rules ()
	381	"Bind each FIELD of a RECORD of the given TYPE to it's FIELD name.
	382	The current implementation does not support thunked and delayed fields."
	383	((_ record type (field fields ...) body ...)
	384	(if (eq? (struct-vtable record) type)
	385	;; TODO compute indices and report wrong-field-name errors at
	386	;; expansion time
	387	;; TODO support thunked and delayed fields
	388	(let ((field ((record-accessor type 'field) record)))
	389	(match-record record type (fields ...) body ...))
	390	(throw 'wrong-type-arg record)))
	391	((_ record type () body ...)
	392	(begin body ...))))
	393
c0cd1b3e	394	;;; records.scm ends here