extended struct-copy so that you copy adjust fields from super structs
This commit is contained in:
Robby Findler
parent
faef39cbc6
commit
614ec41ab7
|
|
@ -654,94 +654,134 @@
|
|||
"not an identifier for field name"
|
||||
stx
|
||||
#'field))]
|
||||
[(field #:parent p val)
|
||||
(unless (identifier? #'field)
|
||||
(raise-syntax-error #f
|
||||
"not an identifier for field name"
|
||||
stx
|
||||
#'field))
|
||||
(unless (identifier? #'p)
|
||||
(raise-syntax-error #f
|
||||
"not an identifier for parent struct name"
|
||||
stx
|
||||
#'field))]
|
||||
[_
|
||||
(raise-syntax-error #f
|
||||
"expected a field update of the form (<field-id> <expr>)"
|
||||
"expected a field update of the form (<field-id> <expr>) or (<field-id> #:parent <parent-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 parent)
|
||||
(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)
|
||||
(list-ref v 5))))])
|
||||
|
||||
(let* ([ensure-really-parent
|
||||
(λ (id)
|
||||
(let loop ([parent parent])
|
||||
(cond
|
||||
[(eq? parent #t)
|
||||
(raise-syntax-error #f "identifier not bound to a parent struct" stx id)]
|
||||
[(not parent)
|
||||
(raise-syntax-error #f "parent struct information not known" stx id)]
|
||||
[(free-identifier=? id parent) (void)]
|
||||
[else
|
||||
(let ([v (syntax-local-value parent (lambda () #f))])
|
||||
(unless (struct-info? v)
|
||||
(raise-syntax-error #f "unknown parent struct" stx id)) ;; probably won't happen(?)
|
||||
(let ([v (extract-struct-info v)])
|
||||
(loop (list-ref v 5))))])))]
|
||||
[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))))]
|
||||
[(field #:parent id expr)
|
||||
(begin
|
||||
(ensure-really-parent #'id)
|
||||
(list (datum->syntax #'field
|
||||
(string->symbol
|
||||
(format "~a-~a"
|
||||
(syntax-e #'id)
|
||||
(syntax-e #'field)))
|
||||
#'field)
|
||||
#'expr
|
||||
(car (generate-temporaries (list #'field)))))]))
|
||||
ans)]
|
||||
|
||||
;; new-binding-for : syntax[field-name] -> (union syntax[expression] #f)
|
||||
[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)))))
|
||||
(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))
|
||||
|
||||
;; 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))))))))]))))
|
||||
|
||||
(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)))))))]))))
|
||||
|
|
|
|||
|
|
@ -388,19 +388,24 @@ by @racket[make-struct-type-property], @racket[#f] otherwise.}
|
|||
@;------------------------------------------------------------------------
|
||||
@section[#:tag "struct-copy"]{Copying and Updating Structures}
|
||||
|
||||
@defform[(struct-copy id struct-expr [field-id expr] ...)]{
|
||||
@defform/subs[(struct-copy id struct-expr fld-id ...)
|
||||
((fld-id [field-id expr]
|
||||
[field-id #:parent parent-id expr]))]{
|
||||
|
||||
Creates a new instance of the structure type @racket[id] with the same
|
||||
field values as the structure produced by @racket[struct-expr], except
|
||||
that the value of each supplied @racket[field-id] is instead
|
||||
determined by the corresponding @racket[expr].
|
||||
determined by the corresponding @racket[expr]. If @racket[#:parent]
|
||||
is specified, the @racket[parent-id] must be bound to a parent
|
||||
structure type of @racket[id].
|
||||
|
||||
The @racket[id] must have a @tech{transformer binding} that
|
||||
encapsulates information about a structure type (i.e., like the
|
||||
initial identifier bound by @racket[struct]), and the binding
|
||||
must supply a constructor, a predicate, and all field accessors.
|
||||
|
||||
Each @racket[field-id] is combined with @racket[id] to form
|
||||
Each @racket[field-id] is combined with @racket[id]
|
||||
(or @racket[parent-id], if present) to form
|
||||
@racket[id]@racketidfont{-}@racket[field-id] (using the lexical
|
||||
context of @racket[field-id]), which must be one of the accessor
|
||||
bindings in @racket[id]. The accessor bindings determined by different
|
||||
|
|
|
|||
|
|
@ -1005,4 +1005,60 @@
|
|||
|
||||
;; ----------------------------------------
|
||||
|
||||
(let ()
|
||||
(struct s (a b))
|
||||
(struct t s (c))
|
||||
(struct u t (d))
|
||||
(test 11
|
||||
'struct-copy1
|
||||
(t-c (struct-copy t (t 1 2 3) [c 11])))
|
||||
(test 11
|
||||
'struct-copy2
|
||||
(s-a (struct-copy t (t 1 2 3) [a #:parent s 11])))
|
||||
(test 11
|
||||
'struct-copy2
|
||||
(s-a (struct-copy u (u 1 2 3 4) [a #:parent s 11])))
|
||||
|
||||
(syntax-test #'(struct-copy t (t 1 2 3) [a #:parent p 11])))
|
||||
|
||||
(let ()
|
||||
(struct s (a b) #:transparent)
|
||||
(struct t s (c) #:transparent)
|
||||
(struct u t (d) #:transparent)
|
||||
(test (t 1 2 11)
|
||||
'struct-copy1
|
||||
(struct-copy t (t 1 2 3) [c 11]))
|
||||
(test (t 11 2 3)
|
||||
'struct-copy2
|
||||
(struct-copy t (t 1 2 3) [a #:parent s 11]))
|
||||
(test (s 11 2)
|
||||
'struct-copy2
|
||||
(struct-copy s (t 1 2 3) [a 11]))
|
||||
(test (u 11 2 3 4)
|
||||
'struct-copy2
|
||||
(struct-copy u (u 1 2 3 4) [a #:parent s 11]))
|
||||
|
||||
(syntax-test #'(struct-copy t (t 1 2 3) [a #:parent p 11])))
|
||||
|
||||
(let ()
|
||||
(struct s (a b) #:prefab)
|
||||
(struct t s (c) #:prefab)
|
||||
(struct u t (d) #:prefab)
|
||||
(test (t 1 2 11)
|
||||
'struct-copy1
|
||||
(struct-copy t (t 1 2 3) [c 11]))
|
||||
(test (t 11 2 3)
|
||||
'struct-copy2
|
||||
(struct-copy t (t 1 2 3) [a #:parent s 11]))
|
||||
(test (s 11 2)
|
||||
'struct-copy2
|
||||
(struct-copy s (t 1 2 3) [a 11]))
|
||||
(test (u 11 2 3 4)
|
||||
'struct-copy2
|
||||
(struct-copy u (u 1 2 3 4) [a #:parent s 11]))
|
||||
|
||||
(syntax-test #'(struct-copy t (t 1 2 3) [a #:parent p 11])))
|
||||
|
||||
;; ----------------------------------------
|
||||
|
||||
(report-errs)
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user