struct-copy

svn: r9456

collects/scheme/private/define-struct.ss

@@ -12,6 +12,7 @@
   (#%provide define-struct*
              define-struct/derived
              struct-field-index
+             struct-copy
              (for-syntax 
 	      (rename checked-struct-info-rec? checked-struct-info?)))
   
@@ -510,5 +511,113 @@
        (raise-syntax-error
         #f
         "bad syntax"
-        stx)])))
+        stx)]))
 
+  (define-syntax (struct-copy stx)
+    (if (not (eq? (syntax-local-context) 'expression))
+        (quasisyntax/loc stx (#%expression #,stx))
+        (syntax-case stx ()
+          [(form-name info struct-expr field+val ...)
+           (let ([ans (syntax->list  #'(field+val ...))])
+             ;; Check syntax:
+             (unless (identifier? #'info)
+               (raise-syntax-error #f "not an identifier for structure type" stx #'info))
+             (for-each (lambda (an)
+                         (syntax-case an ()
+                           [(field val)
+                            (unless (identifier? #'field)
+                              (raise-syntax-error #f 
+                                                  "not an identifier for field name" 
+                                                  stx
+                                                  #'field))]
+                           [_
+                            (raise-syntax-error #f 
+                                                "expected a field update fo the form (<field-id> <expr>)" 
+                                                stx
+                                                an)]))
+                       ans)
+
+             (let ([new-fields
+                    (map (lambda (an)
+                           (syntax-case an ()
+                             [(field expr)
+                              (list (datum->syntax #'field
+                                                   (string->symbol
+                                                    (format "~a-~a"
+                                                            (syntax-e #'info)
+                                                            (syntax-e #'field)))
+                                                   #'field)
+                                    #'expr
+                                    (car (generate-temporaries (list #'field))))]))
+                         ans)])
+
+               ;; new-binding-for : syntax[field-name] -> (union syntax[expression] #f)
+               (let ([new-binding-for 
+                      (lambda (f)
+                        (ormap (lambda (new-field) 
+                                 (and (free-identifier=? (car new-field) f)
+                                      (caddr new-field)))
+                               new-fields))])
+                 
+                 (let-values ([(construct pred accessors)
+                               (let ([v (syntax-local-value #'info (lambda () #f))])
+                                 (unless (struct-info? v)
+                                   (raise-syntax-error #f "identifier is not bound to a structure type" stx #'info))
+                                 (let ([v (extract-struct-info v)])
+                                   (values (cadr v)
+                                           (caddr v)
+                                           (cadddr v))))])
+                   (unless construct
+                     (raise-syntax-error #f
+                                         "constructor not statically known for structure type"
+                                         stx
+                                         #'info))
+                   (unless pred
+                     (raise-syntax-error #f
+                                         "predicate not statically known for structure type"
+                                         stx
+                                         #'info))
+                   (unless (andmap values accessors)
+                     (raise-syntax-error #f
+                                         "not all accessors are statically known for structure type"
+                                         stx
+                                         #'info))
+                   (let ([dests
+                          (map (lambda (new-field)
+                                 (or (ormap (lambda (f2) 
+                                              (and f2 
+                                                   (free-identifier=? (car new-field) f2) 
+                                                   f2))
+                                            accessors)
+                                     (raise-syntax-error #f 
+                                                         "accessor name not associated with the given structure type" 
+                                                         stx
+                                                         (car new-field))))
+                               new-fields)])
+                     ;; Check for duplicates using dests, not as, because mod=? as might not be id=?
+                     (let ((dupe (check-duplicate-identifier dests)))
+                       (when dupe 
+                         (raise-syntax-error #f 
+                                             "duplicate field assignment" 
+                                             stx 
+                                             ;; Map back to an original field:
+                                             (ormap (lambda (nf)
+                                                      (and nf
+                                                           (free-identifier=? dupe (car nf))
+                                                           (car nf)))
+                                                    (reverse new-fields)))))
+                 
+                     ;; the actual result
+                     #`(let ((the-struct struct-expr))
+                         (if (#,pred the-struct)
+                             (let #,(map (lambda (new-field)
+                                           #`[#,(caddr new-field) #,(cadr new-field)])
+                                         new-fields)
+                               (#,construct
+                                #,@(map 
+                                    (lambda (field) (or (new-binding-for field) 
+                                                        #`(#,field the-struct)))
+                                    (reverse accessors))))
+                             (raise-type-error 'form-name 
+                                               #,(format "~a" (syntax-e #'info))
+                                               the-struct))))))))]))))

collects/scheme/private/pre-base.ss

@@ -79,4 +79,5 @@
              procedure-reduce-keyword-arity
              (rename define-struct* define-struct)
              define-struct/derived
-             struct-field-index))
+             struct-field-index
+             struct-copy))

collects/scribblings/guide/define-struct.scrbl

@@ -37,8 +37,8 @@ used directly:
 posn
 ]
 
-We explain one use of the @scheme[_struct-id] binding in the next
+We show two uses of the @scheme[_struct-id] binding below in
-section, @secref["struct-subtypes"].
+@secref["struct-copy"] and @secref["struct-subtypes"].
 
 Meanwhile, in addition to defining @scheme[_struct-id],
 @scheme[define-struct] also defines a number of identifiers that are
@@ -85,6 +85,36 @@ instance of @scheme[posn], even though @scheme["apple"] and
 as requiring them to be numbers, is normally the job of a contract, as
 discussed later in @secref["contracts"].
 
+@; ------------------------------------------------------------
+@section[#:tag "struct-copy"]{Copying and Update}
+
+The @scheme[struct-copy] form clones a structure and optionally
+updates specified fields in the clone. This process is sometimes
+called a @deftech{functional update}, because the result is a
+structure with updated field values. but the original structure is not
+modified.
+
+@specform[
+(struct-copy struct-id struct-expr [field-id expr] ...)
+]
+
+The @scheme[_struct-id] that appears after @scheme[struct-copy] must
+be a structure type name bound by @scheme[define-struct] (i.e., the
+name that cannot be used directly as an expression). The
+@scheme[_struct-expr] must produce an instance of the structure type.
+The result is a new instance of the structure tpe that is like the old
+one, except that the field indicated by each @scheme[_field-id] gets
+the value of the corresponding @scheme[_expr].
+
+@examples[
+#:eval posn-eval 
+(define p1 (make-posn 1 2))
+(define p2 (struct-copy posn p1 [x 3]))
+(list (posn-x p2) (posn-y p2))
+(list (posn-x p1) (posn-x p2))
+]
+
+
 @; ------------------------------------------------------------
 @section[#:tag "struct-subtypes"]{Structure Subtypes}
 

collects/scribblings/reference/struct.scrbl

@@ -4,10 +4,12 @@
 
 @(define struct-eval (make-base-eval))
 
-@title[#:tag "structures"]{Structures}
+@title[#:tag "structures" #:style 'toc]{Structures}
 
 @guideintro["define-struct"]{structure types via @scheme[define-struct]}
 
+@local-table-of-contents[]
+
 A @deftech{structure type} is a record datatype composing a number of
 @idefterm{fields}. A @deftech{structure}, an instance of a structure
 type, is a first-class value that contains a value for each field of
@@ -340,6 +342,40 @@ descriptor} value, @scheme[#f] otherwise.
 
 }
 
+@;------------------------------------------------------------------------
+@section[#:tag "struct-copy"]{Copying and Updating Structures}
+
+@defform[(struct-copy id struct-expr [field-id expr] ...)]{
+
+Creates a new instance of the structure type @scheme[id] with the same
+field values as the structure produced by @scheme[struct-expr], except
+that the value of each supplied @scheme[field-id] is instead
+determined by the corresponding @scheme[expr].
+
+The @scheme[id] must have a @tech{transformer binding} that
+encapsulates information about a structure type (i.e., like the
+initial identifier bound by @scheme[define-struct]), and the binding
+must supply a constructor, a predicate, and all field accessors.
+
+Each @scheme[field-id] is combined with @scheme[id] to form
+@scheme[id]@schemeidfont{-}@scheme[field-id] (using the lexical
+context of @scheme[field-id]), which must be one of the accessor
+bindings in @scheme[id]. The accessor bindings determined by different
+@scheme[field-id]s must be distinct. The order of the
+@scheme[field-id]s need not match the order of the corresponding
+fields in the structure type.
+
+The @scheme[struct-expr] is evaluated first. The result must be an
+instance of the @scheme[id] structure type, otherwise the
+@exnraise[exn:fail:contract]. Next, the field @scheme[expr]s are
+evaluated in order (even if the fields that correspond to the
+@scheme[field-id]s are in a different order). Finally, the new
+structure instance is created.
+
+The result of @scheme[struct-expr] can be an instance of a sub-type of
+@scheme[id], but the resulting copy is an immediate instance of
+@scheme[id] (not the sub-type).}
+
 @;------------------------------------------------------------------------
 @section[#:tag "structutils"]{Structure Utilities}