rekahsoft
/
guix
1
1
Fork 0
Code Issues Pull Requests Releases Wiki Activity

define-record-type*: Add the `thunked' field definition keyword. 

* guix/utils.scm (define-record-type*)[make-syntactic-constructor]: Add
  a `thunked' parameter.
  (thunked-field?, field-bindings): New procedures.  Use the latter when
  generating `letrec*' bindings.
  [thunked-field?, thunked-field-accessor-name, field-spec->srfi-9,
  thunked-field-accessor-name]: New procedures.
  Use them when generating the `define-record-type' form, and to
  generated thunk field accessors, along call to
  `make-syntactic-constructor' with the new argument.
* tests/utils.scm ("define-record-type* & thunked",
  "define-record-type* & thunked & default",
  "define-record-type* & thunked & inherited"): New tests.
This commit is contained in:
Ludovic Courtès 2013-01-23 22:24:47 +01:00
parent 6798a8e485
commit bbb7a00e9a
2 changed files with 135 additions and 17 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

101
guix/utils.scm
View File

@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2012 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2012, 2013 Ludovic Courtès <ludo@gnu.org>
;;;
;;; This file is part of GNU Guix.
;;;
@ -192,10 +192,11 @@ evaluate to a simple datum."
"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."
(define (make-syntactic-constructor type name ctor fields defaults)
(define (make-syntactic-constructor type name ctor fields thunked defaults)
"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."
FIELD/DEFAULT-VALUE tuples, and THUNKED is the list of identifiers of
thunked fields."
(with-syntax ((type type)
(name name)
(ctor ctor)
@ -221,10 +222,23 @@ FIELD/DEFAULT-VALUE tuples."
'expected
(iota (length 'expected)))))
(define (thunked-field? f)
(memq (syntax->datum f) '#,thunked))
(define (field-bindings field+value)
;; Return field to value bindings, for use in `letrec*' below.
(map (lambda (field+value)
(syntax-case field+value ()
((field value)
#`(field
#,(if (thunked-field? #'field)
#'(lambda () value)
#'value)))))
field+value))
(syntax-case s (inherit #,@fields)
((_ (inherit orig-record) (field value) (... ...))
#`(letrec* ((field value) (... ...))
#`(letrec* #,(field-bindings #'((field value) (... ...)))
#,(record-inheritance #'orig-record
#'((field value) (... ...)))))
((_ (field value) (... ...))
@ -239,7 +253,12 @@ FIELD/DEFAULT-VALUE tuples."
(eq? f (car (syntax->datum x))))
#'((field value) (... ...)))
car)
(car (assoc-ref dflt (syntax->datum f)))))
(let ((value
(car (assoc-ref dflt
(syntax->datum f)))))
(if (thunked-field? f)
#`(lambda () #,value)
value))))
(let-syntax ((error*
(syntax-rules ()
@ -250,7 +269,8 @@ FIELD/DEFAULT-VALUE tuples."
s)))))
(let ((fields (append fields (map car dflt))))
(cond ((lset= eq? fields 'expected)
#`(letrec* ((field value) (... ...))
#`(letrec* #,(field-bindings
#'((field value) (... ...)))
(ctor #,@(map field-value 'expected))))
((pair? (lset-difference eq? fields 'expected))
(error* "extraneous field initializers ~a"
@ -268,19 +288,68 @@ FIELD/DEFAULT-VALUE tuples."
(field-default-value #'(field options ...)))
(_ #f)))
(define (thunked-field? s)
;; Return the field name if the field defined by S is thunked.
(syntax-case s (thunked)
((field (thunked) _ ...)
#'field)
((field _ options ...)
(thunked-field? #'(field options ...)))
(_ #f)))
(define (thunked-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.
(syntax-case field ()
((field get options ...)
(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 options ...)
#`(name
#,(if (thunked-field? field)
(thunked-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 (thunked-field-accessor-name field)))
#'(define-inlinable (get x)
;; The real value of that field is a thunk, so call it.
((real-get x)))))))
(syntax-case s ()
((_ type syntactic-ctor ctor pred
(field get options ...) ...)
#`(begin
(define-record-type type
(ctor field ...)
pred
(field get) ...)
#,(make-syntactic-constructor #'type #'syntactic-ctor #'ctor
#'(field ...)
(filter-map field-default-value
#'((field options ...)
...))))))))
(let* ((field-spec #'((field get options ...) ...)))
(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)))
#`(begin
(define-record-type type
(ctor field ...)
pred
field-spec* ...)
(begin thunked-field-accessor ...)
#,(make-syntactic-constructor #'type #'syntactic-ctor #'ctor
#'(field ...)
(filter-map thunked-field? field-spec)
(filter-map field-default-value
#'((field options ...)
...))))))))))
(define (memoize proc)
"Return a memoizing version of PROC."

51
tests/utils.scm
View File

@ -1,5 +1,5 @@
;;; GNU Guix --- Functional package management for GNU
;;; Copyright © 2012 Ludovic Courtès <ludo@gnu.org>
;;; Copyright © 2012, 2013 Ludovic Courtès <ludo@gnu.org>
;;;
;;; This file is part of GNU Guix.
;;;
@ -123,6 +123,55 @@
(match b (($ <foo> 1 2) #t))
(equal? b c)))))
(test-assert "define-record-type* & thunked"
(begin
(define-record-type* <foo> foo make-foo
foo?
(bar foo-bar)
(baz foo-baz (thunked)))
(let* ((calls 0)
(x (foo (bar 2)
(baz (begin (set! calls (1+ calls)) 3)))))
(and (zero? calls)
(equal? (foo-bar x) 2)
(equal? (foo-baz x) 3) (= 1 calls)
(equal? (foo-baz x) 3) (= 2 calls)))))
(test-assert "define-record-type* & thunked & default"
(begin
(define-record-type* <foo> foo make-foo
foo?
(bar foo-bar)
(baz foo-baz (thunked) (default 42)))
(let ((mark (make-parameter #f)))
(let ((x (foo (bar 2) (baz (mark))))
(y (foo (bar 2))))
(and (equal? (foo-bar x) 2)
(parameterize ((mark (cons 'a 'b)))
(eq? (foo-baz x) (mark)))
(equal? (foo-bar y) 2)
(equal? (foo-baz y) 42))))))
(test-assert "define-record-type* & thunked & inherited"
(begin
(define-record-type* <foo> foo make-foo
foo?
(bar foo-bar (thunked))
(baz foo-baz (thunked) (default 42)))
(let ((mark (make-parameter #f)))
(let* ((x (foo (bar 2) (baz (mark))))
(y (foo (inherit x) (bar (mark)))))
(and (equal? (foo-bar x) 2)
(parameterize ((mark (cons 'a 'b)))
(eq? (foo-baz x) (mark)))
(parameterize ((mark (cons 'a 'b)))
(eq? (foo-bar y) (mark)))
(parameterize ((mark (cons 'a 'b)))
(eq? (foo-baz y) (mark))))))))
;; This is actually in (guix store).
(test-equal "store-path-package-name"
"bash-4.2-p24"