ryan77627/guix
1
0
Fork 0
mirror of https://git.in.rschanz.org/ryan77627/guix.git synced 2024-12-24 13:28:12 -05:00
Code Issues Projects Releases Packages Wiki Activity Actions

records: Add support for delayed fields.

Browse source 
* guix/records.scm (make-syntactic-constructor): Add #:delayed
  parameter.
  [delayed-field?]: New procedure.
  [wrap-field-value]: Use it.
  (define-record-type*)[delayed-field?, wrapped-field?]: New procedures.
  [thunked-field-accessor-name]: Rename to...
  [wrapped-field-accessor-name]: ... this.
  [field-spec->srfi-9]: Change 'thunked' to 'wrapped'.
  [delayed-field-accessor-definition]: New procedure.
  Compute delayed-field accessors and emit them.  Pass #:delayed to
  'make-syntactic-constructor'.
* tests/records.scm ("define-record-type* & delayed",
  "define-record-type* & delayed & default",
  "define-record-type* & delayed & inherited"): New tests.
This commit is contained in:
Ludovic Courtès 2015-01-19 23:21:47 +01:00
parent 0db40ed289
commit 310b32a2a6
2 changed files with 98 additions and 12 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

63
guix/records.scm
View file

@ -43,10 +43,12 @@ (define-syntax record-error
form))))
(define* (make-syntactic-constructor type name ctor fields
#:key (thunked '()) (defaults '()))
#:key (thunked '()) (defaults '())
(delayed '()))
"Make the syntactic constructor NAME for TYPE, that calls CTOR, and expects
all of FIELDS to be initialized. DEFAULTS is the list of FIELD/DEFAULT-VALUE
tuples, and THUNKED is the list of identifiers of thunked fields."
tuples, THUNKED is the list of identifiers of thunked fields, and DELAYED is
the list of identifiers of delayed fields."
(with-syntax ((type type)
(name name)
(ctor ctor)
@ -81,10 +83,15 @@ (define (field-inherited-value f)
(define (thunked-field? f)
(memq (syntax->datum f) '#,thunked))
(define (delayed-field? f)
(memq (syntax->datum f) '#,delayed))
(define (wrap-field-value f value)
(if (thunked-field? f)
#`(lambda () #,value)
value))
(cond ((thunked-field? f)
#`(lambda () #,value))
((delayed-field? f)
#`(delay #,value))
(else value)))
(define (field-bindings field+value)
;; Return field to value bindings, for use in 'let*' below.
@ -161,6 +168,9 @@ (define-record-type* <thing> thing make-thing
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\"))
@ -176,6 +186,15 @@ (define (field-default-value s)
(field-default-value #'(field options ...)))
(_ #f)))
(define (delayed-field? s)
;; Return the field name if the field defined by S is delayed.
(syntax-case s (delayed)
((field (delayed) _ ...)
#'field)
((field _ options ...)
(delayed-field? #'(field options ...)))
(_ #f)))
(define (thunked-field? s)
;; Return the field name if the field defined by S is thunked.
(syntax-case s (thunked)
@ -185,9 +204,12 @@ (define (thunked-field? s)
(thunked-field? #'(field options ...)))
(_ #f)))
(define (thunked-field-accessor-name field)
(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 thunked field.
;; getter for field, which is assumed to be a wrapped field.
(syntax-case field ()
((field get options ...)
(let* ((getter (syntax->datum #'get))
@ -200,8 +222,8 @@ (define (field-spec->srfi-9 field)
(syntax-case field ()
((name get options ...)
#`(name
#,(if (thunked-field? field)
(thunked-field-accessor-name field)
#,(if (wrapped-field? field)
(wrapped-field-accessor-name field)
#'get)))))
(define (thunked-field-accessor-definition field)
@ -209,16 +231,27 @@ (define (thunked-field-accessor-definition field)
;; thunked field.
(syntax-case field ()
((name get _ ...)
(with-syntax ((real-get (thunked-field-accessor-name field)))
(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 options ...) ...)
(let* ((field-spec #'((field get options ...) ...))
(thunked (filter-map thunked-field? field-spec))
(delayed (filter-map delayed-field? field-spec))
(defaults (filter-map field-default-value
#'((field options ...) ...))))
(with-syntax (((field-spec* ...)
@ -228,16 +261,24 @@ (define (thunked-field-accessor-definition 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* ...)
(begin thunked-field-accessor ...)
(begin thunked-field-accessor ...
delayed-field-accessor ...)
#,(make-syntactic-constructor #'type #'syntactic-ctor #'ctor
#'(field ...)
#:thunked thunked
#:delayed delayed
#:defaults defaults))))))))
(define* (alist->record alist make keys

47
tests/records.scm
View file

@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2012, 2013, 2014 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2012, 2013, 2014, 2015 Ludovic Courtès <ludo@gnu.org>
;;;
;;; This file is part of GNU Guix.
;;;
@ -139,6 +139,51 @@ (define-record-type* <foo> foo make-foo
(parameterize ((mark (cons 'a 'b)))
(eq? (foo-baz y) (mark))))))))
(test-assert "define-record-type* & delayed"
(begin
(define-record-type* <foo> foo make-foo
foo?
(bar foo-bar (delayed)))
(let* ((calls 0)
(x (foo (bar (begin (set! calls (1+ calls)) 3)))))
(and (zero? calls)
(equal? (foo-bar x) 3) (= 1 calls)
(equal? (foo-bar x) 3) (= 1 calls)
(equal? (foo-bar x) 3) (= 1 calls)))))
(test-assert "define-record-type* & delayed & default"
(let ((mark #f))
(define-record-type* <foo> foo make-foo
foo?
(bar foo-bar (delayed) (default mark)))
(let ((x (foo)))
(set! mark 42)
(and (equal? (foo-bar x) 42)
(begin
(set! mark 7)
(equal? (foo-bar x) 42))))))
(test-assert "define-record-type* & delayed & inherited"
(begin
(define-record-type* <foo> foo make-foo
foo?
(bar foo-bar (delayed))
(baz foo-baz (delayed)))
(let* ((m 1)
(n #f)
(x (foo (bar m) (baz n)))
(y (foo (inherit x) (baz 'b))))
(set! n 'a)
(and (equal? (foo-bar x) 1)
(eq? (foo-baz x) 'a)
(begin
(set! m 777)
(equal? (foo-bar y) 1)) ;promise was already forced
(eq? (foo-baz y) 'b)))))
(test-assert "define-record-type* & missing initializers"
(catch 'syntax-error
(lambda ()