From 8a16d064fa265c449d136ff6c3d3267e314cde8d Mon Sep 17 00:00:00 2001
From: Ludovic Courtès <ludo@gnu.org>
Date: Thu, 11 Jun 2015 22:57:33 +0200
Subject: records: Add support for 'innate' fields.

* guix/records.scm (make-syntactic-constructor): Add #:innate parameter.
  [record-inheritance]: Honor it.
  [innate-field?]: New procedure.
  (define-record-type*)[innate-field?]: New procedure.
  Pass #:innate to 'make-syntactic-constructor'.
* tests/records.scm ("define-record-type* & inherit & innate",
  "define-record-type* & thunked & innate"): New tests.
---
 guix/records.scm  | 20 ++++++++++++++++----
 tests/records.scm | 30 ++++++++++++++++++++++++++++++
 2 files changed, 46 insertions(+), 4 deletions(-)

diff --git a/guix/records.scm b/guix/records.scm
index 816e9f6f01..b68aaae1c4 100644
--- a/guix/records.scm
+++ b/guix/records.scm
@@ -51,6 +51,7 @@ (define-syntax make-syntactic-constructor
     ((_ type name ctor (expected ...)
         #:thunked thunked
         #:delayed delayed
+        #:innate innate
         #:defaults defaults)
      (define-syntax name
        (lambda (s)
@@ -73,8 +74,11 @@ (define (field-inherited-value f)
            #`(make-struct type 0
                           #,@(map (lambda (field index)
                                     (or (field-inherited-value field)
-                                        #`(struct-ref #,orig-record
-                                                      #,index)))
+                                        (if (innate-field? field)
+                                            (wrap-field-value
+                                             field (field-default-value field))
+                                            #`(struct-ref #,orig-record
+                                                          #,index))))
                                   '(expected ...)
                                   (iota (length '(expected ...))))))
 
@@ -84,6 +88,9 @@ (define (thunked-field? f)
          (define (delayed-field? f)
            (memq (syntax->datum f) 'delayed))
 
+         (define (innate-field? f)
+           (memq (syntax->datum f) 'innate))
+
          (define (wrap-field-value f value)
            (cond ((thunked-field? f)
                   #`(lambda () #,value))
@@ -164,7 +171,8 @@ (define-record-type* <thing> thing make-thing
     thing?
     (name  thing-name (default \"chbouib\"))
     (port  thing-port
-           (default (current-output-port)) (thunked)))
+           (default (current-output-port)) (thunked))
+    (loc   thing-location (innate) (default (current-source-location))))
 
 This example defines a macro 'thing' that can be used to instantiate records
 of this type:
@@ -190,7 +198,8 @@ (define-record-type* <thing> thing make-thing
   (thing (inherit x) (name \"bar\"))
 
 This expression returns a new object equal to 'x' except for its 'name'
-field."
+field and its 'loc' field---the latter is marked as \"innate\", so it is not
+inherited."
 
     (define (field-default-value s)
       (syntax-case s (default)
@@ -202,6 +211,7 @@ (define (field-default-value s)
 
     (define-field-property-predicate delayed-field? delayed)
     (define-field-property-predicate thunked-field? thunked)
+    (define-field-property-predicate innate-field? innate)
 
     (define (wrapped-field? s)
       (or (thunked-field? s) (delayed-field? s)))
@@ -251,6 +261,7 @@ (define (delayed-field-accessor-definition field)
        (let* ((field-spec #'((field get properties ...) ...))
               (thunked    (filter-map thunked-field? field-spec))
               (delayed    (filter-map delayed-field? field-spec))
+              (innate     (filter-map innate-field? field-spec))
               (defaults   (filter-map field-default-value
                                       #'((field properties ...) ...))))
          (with-syntax (((field-spec* ...)
@@ -278,6 +289,7 @@ (define-record-type type
                                            (field ...)
                                            #:thunked #,thunked
                                            #:delayed #,delayed
+                                           #:innate #,innate
                                            #:defaults #,defaults))))))))
 
 (define* (alist->record alist make keys
diff --git a/tests/records.scm b/tests/records.scm
index a00e38db7d..6346c154cd 100644
--- a/tests/records.scm
+++ b/tests/records.scm
@@ -90,6 +90,20 @@ (define-record-type* <foo> foo make-foo
           (match b (($ <foo> 1 2) #t))
           (equal? b c)))))
 
+(test-assert "define-record-type* & inherit & innate"
+  (begin
+    (define-record-type* <foo> foo make-foo
+      foo?
+      (bar foo-bar (innate) (default 42)))
+    (let* ((a (foo (bar 1)))
+           (b (foo (inherit a)))
+           (c (foo (inherit a) (bar 3)))
+           (d (foo)))
+      (and (match a (($ <foo> 1) #t))
+           (match b (($ <foo> 42) #t))
+           (match c (($ <foo> 3) #t))
+           (match d (($ <foo> 42) #t))))))
+
 (test-assert "define-record-type* & thunked"
   (begin
     (define-record-type* <foo> foo make-foo
@@ -139,6 +153,22 @@ (define-record-type* <foo> foo make-foo
              (parameterize ((mark (cons 'a 'b)))
                (eq? (foo-baz y) (mark))))))))
 
+(test-assert "define-record-type* & thunked & innate"
+  (let ((mark (make-parameter #f)))
+    (define-record-type* <foo> foo make-foo
+      foo?
+      (bar foo-bar (thunked) (innate) (default (mark)))
+      (baz foo-baz (default #f)))
+
+    (let* ((x (foo (bar 42)))
+           (y (foo (inherit x) (baz 'unused))))
+      (and (procedure? (struct-ref x 0))
+           (equal? (foo-bar x) 42)
+           (parameterize ((mark (cons 'a 'b)))
+             (eq? (foo-bar y) (mark)))
+           (parameterize ((mark (cons 'a 'b)))
+             (eq? (foo-bar y) (mark)))))))
+
 (test-assert "define-record-type* & delayed"
   (begin
     (define-record-type* <foo> foo make-foo
-- 
cgit v1.2.3