records: Make 'make-syntactic-constructor' available at load/eval/expand.

* guix/records.scm (make-syntactic-constructor): Wrap in 'eval-when'.

1 files changed, 97 insertions, 93 deletions

diff --git a/guix/records.scm b/guix/records.scm
index fd17e135e1..db59a99052 100644
--- a/guix/records.scm
+++ b/guix/records.scm
@@ -42,102 +42,106 @@
                        (format #f fmt args ...)
                        form))))
 
-(define* (make-syntactic-constructor type name ctor fields
-                                     #:key (thunked '()) (defaults '())
-                                     (delayed '()))
-  "Make the syntactic constructor NAME for TYPE, that calls CTOR, and expects
+(eval-when (expand load eval)
+  ;; This procedure is a syntactic helper used by 'define-record-type*', hence
+  ;; 'eval-when'.
+
+  (define* (make-syntactic-constructor type name ctor fields
+                                       #: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, 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)
-                (expected fields)
-                (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 type 0
-                           #,@(map (lambda (field index)
-                                     (or (field-inherited-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 (wrap-field-value f 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.
-            (map (lambda (field+value)
-                   (syntax-case field+value ()
-                     ((field value)
-                      #`(field
-                         #,(wrap-field-value #'field #'value)))))
-                 field+value))
-
-          (syntax-case s (inherit #,@fields)
-            ((_ (inherit orig-record) (field value) (... ...))
-             #`(let* #,(field-bindings #'((field value) (... ...)))
-                 #,(record-inheritance #'orig-record
-                                       #'((field value) (... ...)))))
-            ((_ (field value) (... ...))
-             (let ((fields (map syntax->datum #'(field (... ...))))
-                   (dflt   (map (match-lambda
-                                 ((f v)
-                                  (list (syntax->datum f) v)))
-                                #'defaults)))
-
-               (define (field-value f)
-                 (or (and=> (find (lambda (x)
-                                    (eq? f (car (syntax->datum x))))
-                                  #'((field value) (... ...)))
-                            car)
-                     (let ((value
-                            (car (assoc-ref dflt (syntax->datum f)))))
-                       (wrap-field-value f value))))
-
-               (let ((fields (append fields (map car dflt))))
-                 (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))))))))))))
+    (with-syntax ((type     type)
+                  (name     name)
+                  (ctor     ctor)
+                  (expected fields)
+                  (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 type 0
+                             #,@(map (lambda (field index)
+                                       (or (field-inherited-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 (wrap-field-value f 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.
+              (map (lambda (field+value)
+                     (syntax-case field+value ()
+                       ((field value)
+                        #`(field
+                           #,(wrap-field-value #'field #'value)))))
+                   field+value))
+
+            (syntax-case s (inherit #,@fields)
+              ((_ (inherit orig-record) (field value) (... ...))
+               #`(let* #,(field-bindings #'((field value) (... ...)))
+                   #,(record-inheritance #'orig-record
+                                         #'((field value) (... ...)))))
+              ((_ (field value) (... ...))
+               (let ((fields (map syntax->datum #'(field (... ...))))
+                     (dflt   (map (match-lambda
+                                    ((f v)
+                                     (list (syntax->datum f) v)))
+                                  #'defaults)))
+
+                 (define (field-value f)
+                   (or (and=> (find (lambda (x)
+                                      (eq? f (car (syntax->datum x))))
+                                    #'((field value) (... ...)))
+                              car)
+                       (let ((value
+                              (car (assoc-ref dflt (syntax->datum f)))))
+                         (wrap-field-value f value))))
+
+                 (let ((fields (append fields (map car dflt))))
+                   (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)))))))))))))
 
 (define-syntax define-record-type*
   (lambda (s)