summaryrefslogtreecommitdiff
diff options
context:
space:
mode:
authorLudovic Courtès <ludo@gnu.org>2012-06-27 23:40:12 +0200
committerLudovic Courtès <ludo@gnu.org>2012-06-27 23:40:12 +0200
commit72d869634bd22d978af13f5a8c89ddff27140422 (patch)
tree17da8e80b8bcf56c4ad7c3058e81846c8b719915
parent0d56a551bf5f1cf94f59cf508b3820bcc8fd8050 (diff)
downloadpatches-72d869634bd22d978af13f5a8c89ddff27140422.tar
patches-72d869634bd22d978af13f5a8c89ddff27140422.tar.gz
Add `define-record-type*'.
* guix/utils.scm (define-record-type*): New macro. * tests/utils.scm ("define-record-type*"): New test.
-rw-r--r--guix/utils.scm63
-rw-r--r--tests/utils.scm16
2 files changed, 78 insertions, 1 deletions
diff --git a/guix/utils.scm b/guix/utils.scm
index 5415ab9e63..05c04b87f1 100644
--- a/guix/utils.scm
+++ b/guix/utils.scm
@@ -18,6 +18,7 @@
(define-module (guix utils)
#:use-module (srfi srfi-1)
+ #:use-module (srfi srfi-9)
#:use-module (srfi srfi-26)
#:use-module (srfi srfi-39)
#:use-module (srfi srfi-60)
@@ -27,6 +28,7 @@
#:autoload (ice-9 popen) (open-pipe*)
#:autoload (ice-9 rdelim) (read-line)
#:use-module (ice-9 regex)
+ #:use-module (ice-9 match)
#:use-module ((chop hash)
#:select (bytevector-hash
hash-method/sha256))
@@ -42,6 +44,7 @@
%nixpkgs-directory
nixpkgs-derivation
+ define-record-type*
memoize
gnu-triplet->nix-system
%current-system))
@@ -391,6 +394,66 @@ starting from the right of S."
;;; Miscellaneous.
;;;
+(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."
+ (define (make-syntactic-constructor name ctor fields defaults)
+ "Make the syntactic constructor NAME that calls CTOR, and expects all
+of FIELDS to be initialized. DEFAULTS is the list of FIELD/DEFAULT-VALUE
+tuples."
+ (with-syntax ((name name)
+ (ctor ctor)
+ (expected fields)
+ (defaults defaults))
+ #'(define-syntax name
+ (lambda (s)
+ (syntax-case s expected
+ ((_ (field value) (... ...))
+ (let ((fields (map syntax->datum #'(field (... ...))))
+ (inits (map (match-lambda
+ ((f v)
+ (list (syntax->datum f) v)))
+ #'((field value) (... ...))))
+ (dflt (map (match-lambda
+ ((f v)
+ (list (syntax->datum f) v)))
+ #'defaults)))
+
+ (define (field-value f)
+ (match (assoc f inits)
+ ((_ v) v)
+ (#f (car (assoc-ref dflt f)))))
+
+ (if (lset= eq? (append fields (map car dflt))
+ 'expected)
+ #`(ctor #,@(map field-value 'expected))
+ (error "missing or extraneous field initializers"
+ (lset-difference eq? fields 'expected))))))))))
+
+ (define (field-default-value s)
+ (syntax-case s (default)
+ ((field (default val) _ ...)
+ (list #'field #'val))
+ ((field _ options ...)
+ (field-default-value #'(field options ...)))
+ (_ #f)))
+
+ (syntax-case s ()
+ ((_ type syntactic-ctor ctor pred
+ (field get options ...) ...)
+ #`(begin
+ (define-record-type type
+ (ctor field ...)
+ pred
+ (field get) ...)
+ #,(make-syntactic-constructor #'syntactic-ctor #'ctor
+ #'(field ...)
+ (filter-map field-default-value
+ #'((field options ...)
+ ...))))))))
+
(define (memoize proc)
"Return a memoizing version of PROC."
(let ((cache (make-hash-table)))
diff --git a/tests/utils.scm b/tests/utils.scm
index b3c7fefa39..83a78b7a78 100644
--- a/tests/utils.scm
+++ b/tests/utils.scm
@@ -26,7 +26,8 @@
#:use-module (rnrs bytevectors)
#:use-module (rnrs io ports)
#:use-module (ice-9 rdelim)
- #:use-module (ice-9 popen))
+ #:use-module (ice-9 popen)
+ #:use-module (ice-9 match))
(test-begin "utils")
@@ -98,6 +99,19 @@
(equal? nix (gnu-triplet->nix-system gnu)))
gnu nix))))
+(test-assert "define-record-type*"
+ (begin
+ (define-record-type* <foo> foo make-foo
+ foo?
+ (bar foo-bar)
+ (baz foo-baz (default (+ 40 2))))
+ (and (match (foo (bar 1) (baz 2))
+ (($ <foo> 1 2) #t))
+ (match (foo (baz 2) (bar 1))
+ (($ <foo> 1 2) #t))
+ (match (foo (bar 1))
+ (($ <foo> 1 42) #t)))))
+
(test-end)