Move record utilities to (guix records).

* guix/utils.scm (define-record-type*): Move to...
* guix/records.scm: ... here.  New file.
* guix/build-system.scm, guix/packages.scm: Use it.
* guix/gnu-maintenance.scm: Likewise.
  (official-gnu-packages)[alist->record]: Remove.
* guix/scripts/substitute-binary.scm: Likewise.
  (alist->record, object->fields): Remove.
* tests/utils.scm ("define-record-type*", "define-record-type* with
  letrec* behavior", "define-record-type* & inherit",
  "define-record-type* & inherit & letrec* behavior",
  "define-record-type* & thunked", "define-record-type* & thunked &
  default", "define-record-type* & thunked & inherited"): Move to...
* tests/records.scm: ... here.  New file.

1 files changed, 0 insertions, 165 deletions

diff --git a/guix/utils.scm b/guix/utils.scm
index 7c8e914c01..c2d2808f76 100644
--- a/guix/utils.scm
+++ b/guix/utils.scm
@@ -42,7 +42,6 @@
             nixpkgs-derivation
             nixpkgs-derivation*
 
-            define-record-type*
             compile-time-value
             memoize
             default-keyword-arguments
@@ -239,170 +238,6 @@ wait."
 ;;; 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 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, and THUNKED is the list of identifiers of
-thunked 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-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 (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-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)))))
-                           (if (thunked-field? f)
-                               #`(lambda () #,value)
-                               value))))
-
-                   (let-syntax ((error*
-                                 (syntax-rules ()
-                                   ((_ fmt args (... ...))
-                                    (syntax-violation 'name
-                                                      (format #f fmt args
-                                                              (... ...))
-                                                      s)))))
-                     (let ((fields (append fields (map car dflt))))
-                       (cond ((lset= eq? fields 'expected)
-                              #`(letrec* #,(field-bindings
-                                            #'((field value) (... ...)))
-                                  (ctor #,@(map field-value 'expected))))
-                             ((pair? (lset-difference eq? fields 'expected))
-                              (error* "extraneous field initializers ~a"
-                                      (lset-difference eq? fields 'expected)))
-                             (else
-                              (error* "missing field initializers ~a"
-                                      (lset-difference eq? 'expected
-                                                       fields)))))))))))))
-
-    (define (field-default-value s)
-      (syntax-case s (default)
-        ((field (default val) _ ...)
-         (list #'field #'val))
-        ((field _ options ...)
-         (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 ...) ...)
-       (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."
   (let ((cache (make-hash-table)))