From 1ee02985521e03e69c70f67b4c44b85528f2381f Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Thu, 24 Apr 2008 13:56:36 +0000 Subject: [PATCH] struct-copy svn: r9456 --- collects/scheme/private/define-struct.ss | 113 +++++++++++++++++- collects/scheme/private/pre-base.ss | 3 +- .../scribblings/guide/define-struct.scrbl | 34 +++++- collects/scribblings/reference/struct.scrbl | 38 +++++- 4 files changed, 182 insertions(+), 6 deletions(-) diff --git a/collects/scheme/private/define-struct.ss b/collects/scheme/private/define-struct.ss index 884cf59ccb..c89aa77dfc 100644 --- a/collects/scheme/private/define-struct.ss +++ b/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 ( )" + 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))))))))])))) diff --git a/collects/scheme/private/pre-base.ss b/collects/scheme/private/pre-base.ss index 84a389fca4..a34751c581 100644 --- a/collects/scheme/private/pre-base.ss +++ b/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)) diff --git a/collects/scribblings/guide/define-struct.scrbl b/collects/scribblings/guide/define-struct.scrbl index 89a3092ece..45b19059d7 100644 --- a/collects/scribblings/guide/define-struct.scrbl +++ b/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 -section, @secref["struct-subtypes"]. +We show two uses of the @scheme[_struct-id] binding below in +@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} diff --git a/collects/scribblings/reference/struct.scrbl b/collects/scribblings/reference/struct.scrbl index f27df57f8f..d2ffedf435 100644 --- a/collects/scribblings/reference/struct.scrbl +++ b/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}