Implemented struct/contract and testing for struct/contract
This commit is contained in:
Tommy McHugh
Robby Findler
parent
af3c22dd11
commit
0d1a85237e
|
|
@ -2055,13 +2055,40 @@ positions and the @racket[define/contract] form for the negative ones.
|
|||
(eval:error (numbers->strings '(4.0 3.3 5.8)))
|
||||
]}
|
||||
|
||||
@defform*[[(struct/contract struct-id ([field contract-expr] ...)
|
||||
struct-option ...)
|
||||
(struct/contract struct-id super-struct-id
|
||||
([field contract-expr] ...)
|
||||
struct-option ...)]]{
|
||||
Works like @racket[struct], except that the arguments to the constructor,
|
||||
accessors, and mutators are protected by contracts. For the definitions of
|
||||
@racket[field] and @racket[struct-option], see @racket[struct].
|
||||
|
||||
The @racket[struct/contract] form only allows a subset of the
|
||||
@racket[struct-option] keywords: @racket[#:mutable], @racket[#:transparent],
|
||||
@racket[#:auto-value], @racket[#:omit-define-syntaxes], @racket[#:property] and
|
||||
@racket[#:omit-define-values].
|
||||
|
||||
@examples[#:eval (contract-eval) #:once
|
||||
(struct/contract fruit ([seeds number?]))
|
||||
(fruit 60)
|
||||
(eval:error (fruit #f))
|
||||
|
||||
(struct/contract apple fruit ([type string?]))
|
||||
(apple 14 "golden delicious")
|
||||
(eval:error (apple 5 30))
|
||||
(eval:error (apple #f "granny smith"))
|
||||
]}
|
||||
|
||||
@defform*[[(define-struct/contract struct-id ([field contract-expr] ...)
|
||||
struct-option ...)
|
||||
(define-struct/contract (struct-id super-struct-id)
|
||||
([field contract-expr] ...)
|
||||
struct-option ...)]]{
|
||||
Works like @racket[define-struct], except that the arguments to the constructor,
|
||||
accessors, and mutators are protected by contracts. For the definitions of
|
||||
Works like @racket[struct/contract], except that the syntax for supplying a
|
||||
@racket[super-struct-id] is different, and a @racket[_constructor-id] that
|
||||
has a @racketidfont{make-} prefix on @racket[struct-id] is implicitly
|
||||
supplied. For the definitions of
|
||||
@racket[field] and @racket[struct-option], see @racket[define-struct].
|
||||
|
||||
The @racket[define-struct/contract] form only allows a subset of the
|
||||
|
|
|
|||
204
pkgs/racket-test/tests/racket/contract/struct-contract.rkt
Normal file
204
pkgs/racket-test/tests/racket/contract/struct-contract.rkt
Normal file
|
|
@ -0,0 +1,204 @@
|
|||
#lang racket/base
|
||||
(require "test-util.rkt")
|
||||
|
||||
(parameterize ([current-contract-namespace
|
||||
(make-basic-contract-namespace 'racket/contract
|
||||
'racket/match)])
|
||||
(test/spec-passed
|
||||
'struct/contract1
|
||||
'(let ()
|
||||
(struct/contract foobar ([x number?] [y number?]))
|
||||
1))
|
||||
|
||||
(test/spec-passed
|
||||
'struct/contract2
|
||||
'(let ()
|
||||
(struct/contract foobar ([x number?] [y number?]))
|
||||
(foobar 1 2)))
|
||||
|
||||
(test/spec-failed
|
||||
'struct/contract3
|
||||
'(let ()
|
||||
(struct/contract foobar ([x number?] [y number?]))
|
||||
(foobar 1 #t))
|
||||
"top-level")
|
||||
|
||||
(test/spec-passed
|
||||
'struct/contract4
|
||||
'(let ()
|
||||
(struct/contract foobar ([x number?] [y number?]))
|
||||
(foobar-y (foobar 2 3))))
|
||||
|
||||
(test/spec-failed
|
||||
'struct/contract5
|
||||
'(let ()
|
||||
(struct/contract foobar ([x number?] [y number?]))
|
||||
(foobar-y 1))
|
||||
"top-level")
|
||||
|
||||
(test/spec-passed
|
||||
'struct/contract6
|
||||
'(let ()
|
||||
(struct/contract foobar ([x number?] [y number?]) #:mutable)
|
||||
(set-foobar-y! (foobar 1 2) 3)
|
||||
(set-foobar-x! (foobar 1 2) 3)))
|
||||
|
||||
(test/spec-failed
|
||||
'struct/contract7
|
||||
'(let ()
|
||||
(struct/contract foobar ([x number?] [y number?]) #:mutable)
|
||||
(set-foobar-y! (foobar 1 2) #f))
|
||||
"top-level")
|
||||
|
||||
(test/spec-passed
|
||||
'struct/contract8
|
||||
'(let ()
|
||||
(struct/contract foobar ([(x #:mutable) number?] [y number?]))
|
||||
(set-foobar-x! (foobar 1 2) 4)))
|
||||
|
||||
(test/spec-failed
|
||||
'struct/contract9
|
||||
'(let ()
|
||||
(struct/contract foobar ([(x #:mutable) number?] [y number?]))
|
||||
(set-foobar-x! (foobar 1 2) #f))
|
||||
"top-level")
|
||||
|
||||
(test/spec-failed
|
||||
'struct/contract10
|
||||
'(let ()
|
||||
(struct/contract foobar ([x number?] [(y #:auto) number?]))
|
||||
(foobar 1))
|
||||
"(struct foobar)")
|
||||
|
||||
(test/spec-passed
|
||||
'struct/contract11
|
||||
'(let ()
|
||||
(struct/contract foobar ([x number?] [(y #:auto) number?]) #:auto-value 3)
|
||||
(foobar 1)))
|
||||
|
||||
(test/spec-passed
|
||||
'struct/contract12
|
||||
'(let ()
|
||||
(struct/contract foobar ([x number?] [(y #:auto #:mutable) number?]) #:auto-value 3)
|
||||
(set-foobar-y! (foobar 1) 3)))
|
||||
|
||||
(test/spec-failed
|
||||
'struct/contract13
|
||||
'(let ()
|
||||
(struct/contract foobar ([x number?] [(y #:auto #:mutable) number?]) #:auto-value 3)
|
||||
(set-foobar-y! (foobar 1) #t))
|
||||
"top-level")
|
||||
|
||||
(test/spec-passed
|
||||
'struct/contract14
|
||||
'(let ()
|
||||
(struct/contract foobar ([x number?] [y number?]) #:transparent)
|
||||
1))
|
||||
|
||||
(test/spec-passed
|
||||
'struct/contract15
|
||||
'(let ()
|
||||
(define-struct foobar (x))
|
||||
(struct/contract bar foobar ([z string?]))
|
||||
(bar 2 "x")))
|
||||
|
||||
(test/spec-failed
|
||||
'struct/contract16
|
||||
'(let ()
|
||||
(define-struct foobar (x))
|
||||
(struct/contract bar foobar ([z string?]))
|
||||
(bar 2 #f))
|
||||
"top-level")
|
||||
|
||||
(test/spec-passed
|
||||
'struct/contract17
|
||||
'(let ()
|
||||
(define-struct foobar (x))
|
||||
(struct/contract bar foobar ([z string?]) #:mutable)
|
||||
(set-bar-z! (bar 2 "x") "y")))
|
||||
|
||||
(test/spec-failed
|
||||
'struct/contract18
|
||||
'(let ()
|
||||
(define-struct foobar (x))
|
||||
(struct/contract bar foobar ([z string?]) #:mutable)
|
||||
(set-bar-z! (bar 2 "x") #f))
|
||||
"top-level")
|
||||
|
||||
(test/spec-passed
|
||||
'struct/contract19
|
||||
'(let ()
|
||||
(define-struct foobar (x))
|
||||
(struct/contract bar foobar ([z string?]))
|
||||
(struct/contract baz bar ([x number?]))
|
||||
(baz 2 "x" 5)))
|
||||
|
||||
(test/spec-failed
|
||||
'struct/contract20
|
||||
'(let ()
|
||||
(define-struct foobar (x))
|
||||
(struct/contract bar foobar ([z string?]))
|
||||
(struct/contract baz bar ([x number?]))
|
||||
(baz 2 "x" #f))
|
||||
"top-level")
|
||||
|
||||
(test/spec-failed
|
||||
'struct/contract21
|
||||
'(let ()
|
||||
(define-struct foobar (x))
|
||||
(struct/contract bar foobar ([z string?]))
|
||||
(struct/contract baz bar ([x number?]))
|
||||
(baz 2 #f 3))
|
||||
"top-level")
|
||||
|
||||
(test/spec-passed
|
||||
'struct/contract21
|
||||
'(let ()
|
||||
(define-struct foobar (x) #:mutable)
|
||||
(struct/contract bar foobar ([z string?]))
|
||||
(set-foobar-x! (bar 2 "x") #f)))
|
||||
|
||||
(test/spec-passed
|
||||
'struct/contract22
|
||||
'(struct/contract foobar ([x number?] [y number?]) #:mutable #:transparent))
|
||||
|
||||
(test/spec-passed
|
||||
'struct/contract23
|
||||
'(struct/contract foobar ([x number?] [y number?])
|
||||
#:mutable #:transparent
|
||||
#:property prop:custom-write
|
||||
(lambda (a b c) (void))))
|
||||
|
||||
(test/spec-passed/result
|
||||
'struct/contract24
|
||||
'(let ()
|
||||
(struct/contract point
|
||||
([x number?] [y number?])
|
||||
#:transparent)
|
||||
(struct/contract color-point point
|
||||
([c symbol?])
|
||||
#:transparent)
|
||||
|
||||
(match (color-point 1 2 'red)
|
||||
[(struct color-point [dx dy color])
|
||||
(list dx dy color)]
|
||||
[(struct point [dx dy]) (list dx dy)]
|
||||
[v (box v)]))
|
||||
(list 1 2 'red))
|
||||
|
||||
(test/spec-passed
|
||||
'struct/contract25
|
||||
'(let ()
|
||||
(struct/contract point
|
||||
([x number?] [y number?])
|
||||
#:transparent)
|
||||
(point 1 2)))
|
||||
|
||||
(test/spec-failed
|
||||
'struct/contract26
|
||||
'(let ()
|
||||
(struct/contract point
|
||||
([x number?] [y number?])
|
||||
#:transparent)
|
||||
(point 1 #t))
|
||||
"top-level"))
|
||||
|
|
@ -1,6 +1,7 @@
|
|||
#lang racket/base
|
||||
|
||||
(provide define-struct/contract
|
||||
struct/contract
|
||||
define/contract
|
||||
with-contract
|
||||
current-contract-region
|
||||
|
|
@ -123,332 +124,392 @@
|
|||
stx)]
|
||||
[_ #'orig])))))
|
||||
|
||||
(define-syntax (define-struct/contract stx)
|
||||
(define-struct field-info (stx ctc [mutable? #:mutable] auto?))
|
||||
(define-struct s-info (auto-value-stx transparent? def-stxs? def-vals?))
|
||||
(define-syntaxes (define-struct/contract struct/contract)
|
||||
(let* ([parse-syntax (lambda (stx type)
|
||||
(define-struct field-info (stx ctc [mutable? #:mutable] auto?))
|
||||
(define-struct s-info (auto-value-stx transparent? def-stxs? def-vals?))
|
||||
|
||||
(define syntax-error
|
||||
(lambda v
|
||||
(apply raise-syntax-error 'define-struct/contract v)))
|
||||
|
||||
(define (build-struct-names name field-infos)
|
||||
(let ([name-str (symbol->string (syntax-case name ()
|
||||
[id (identifier? #'id)
|
||||
(syntax-e #'id)]
|
||||
[(sub super)
|
||||
(syntax-e #'sub)]))])
|
||||
(list*
|
||||
(syntax-case name ()
|
||||
[id (identifier? #'id) #'id]
|
||||
[(sub super) #'sub])
|
||||
(syntax-case name ()
|
||||
[id (identifier? #'id) #'#f]
|
||||
[(sub super) #'super])
|
||||
(datum->syntax
|
||||
name
|
||||
(string->symbol
|
||||
(string-append "struct:" name-str)))
|
||||
(datum->syntax
|
||||
name
|
||||
(string->symbol
|
||||
(string-append "make-" name-str)))
|
||||
(datum->syntax
|
||||
name
|
||||
(string->symbol
|
||||
(string-append name-str "?")))
|
||||
(apply append
|
||||
(for/list ([finfo field-infos])
|
||||
(let ([field-str (symbol->string (syntax-e (field-info-stx finfo)))])
|
||||
(cons (datum->syntax
|
||||
name
|
||||
(string->symbol
|
||||
(string-append name-str "-" field-str)))
|
||||
(if (field-info-mutable? finfo)
|
||||
(list (datum->syntax
|
||||
name
|
||||
(string->symbol
|
||||
(string-append "set-" name-str "-" field-str "!"))))
|
||||
null))))))))
|
||||
|
||||
(define (build-contracts stx pred field-infos)
|
||||
(list* (syntax/loc stx any/c)
|
||||
(syntax/loc stx any/c)
|
||||
(apply append
|
||||
(for/list ([finfo field-infos])
|
||||
(let ([field-ctc (field-info-ctc finfo)])
|
||||
(cons (quasisyntax/loc stx
|
||||
(-> #,pred #,field-ctc))
|
||||
(if (field-info-mutable? finfo)
|
||||
(list
|
||||
(quasisyntax/loc stx
|
||||
(-> #,pred #,field-ctc void?)))
|
||||
null)))))))
|
||||
|
||||
(define (check-field f ctc)
|
||||
(let ([p-list (syntax->list f)])
|
||||
(if p-list
|
||||
(begin
|
||||
(when (null? p-list)
|
||||
(syntax-error "expected struct field" f))
|
||||
(unless (identifier? (car p-list))
|
||||
(syntax-error "expected identifier" f))
|
||||
(let loop ([rest (cdr p-list)]
|
||||
[mutable? #f]
|
||||
[auto? #f])
|
||||
(if (null? rest)
|
||||
(make-field-info (car p-list) ctc mutable? auto?)
|
||||
(let ([elem (syntax-e (car rest))])
|
||||
(if (keyword? elem)
|
||||
(cond
|
||||
[(eq? elem '#:mutable)
|
||||
(begin (when mutable?
|
||||
(syntax-error "redundant #:mutable"
|
||||
(car rest)))
|
||||
(loop (cdr rest) #t auto?))]
|
||||
[(eq? elem '#:auto)
|
||||
(begin (when auto?
|
||||
(syntax-error "redundant #:mutable"
|
||||
(car rest)))
|
||||
(loop (cdr rest) mutable? #t))]
|
||||
[else (syntax-error "expected #:mutable or #:auto"
|
||||
(car rest))])
|
||||
(syntax-error "expected #:mutable or #:auto"
|
||||
(car rest)))))))
|
||||
(if (identifier? f)
|
||||
(make-field-info f ctc #f #f)
|
||||
(syntax-error "expected struct field" f)))))
|
||||
(define (check-kwds kwd-list field-infos)
|
||||
(let loop ([kwds kwd-list]
|
||||
[auto-value-stx #f]
|
||||
[mutable? #f]
|
||||
[transparent? #f]
|
||||
[def-stxs? #t]
|
||||
[def-vals? #t])
|
||||
(if (null? kwds)
|
||||
(make-s-info auto-value-stx transparent? def-stxs? def-vals?)
|
||||
(let ([kwd (syntax-e (car kwds))])
|
||||
(when (not (keyword? kwd))
|
||||
(syntax-error "expected a keyword"
|
||||
(car kwds)))
|
||||
(cond
|
||||
[(eq? kwd '#:auto-value)
|
||||
(when (null? (cdr kwds))
|
||||
(syntax-error "expected a following expression"
|
||||
(car kwds)))
|
||||
(loop (cddr kwds) (cadr kwds)
|
||||
transparent? mutable? def-stxs? def-vals?)]
|
||||
;; let arbitrary properties through
|
||||
[(eq? kwd '#:property)
|
||||
(when (null? (cdr kwds))
|
||||
(syntax-error "expected a property"
|
||||
(car kwds)))
|
||||
(when (null? (cddr kwds))
|
||||
(syntax-error "expected a value for the property"
|
||||
(car kwds)))
|
||||
(loop (cdddr kwds) auto-value-stx
|
||||
mutable? transparent? def-stxs? def-vals?)]
|
||||
[(eq? kwd '#:mutable)
|
||||
(when mutable?
|
||||
(syntax-error "redundant #:mutable"
|
||||
(car kwds)))
|
||||
(for ([finfo field-infos])
|
||||
(set-field-info-mutable?! finfo #t))
|
||||
(loop (cdr kwds) auto-value-stx
|
||||
#t transparent? def-stxs? def-vals?)]
|
||||
[(eq? kwd '#:transparent)
|
||||
(when transparent?
|
||||
(syntax-error "redundant #:transparent"
|
||||
(car kwds)))
|
||||
(loop (cdr kwds) auto-value-stx
|
||||
mutable? #t def-stxs? def-vals?)]
|
||||
[(eq? kwd '#:omit-define-syntaxes)
|
||||
(when (not def-stxs?)
|
||||
(syntax-error "redundant #:omit-define-syntaxes"
|
||||
(car kwds)))
|
||||
(loop (cdr kwds) auto-value-stx
|
||||
transparent? mutable? #f def-vals?)]
|
||||
[(eq? kwd '#:omit-define-values)
|
||||
(when (not def-vals?)
|
||||
(syntax-error "redundant #:omit-define-values"
|
||||
(car kwds)))
|
||||
(loop (cdr kwds) auto-value-stx
|
||||
transparent? mutable? def-stxs? #f)]
|
||||
[else (syntax-error "unexpected keyword"
|
||||
(car kwds))])))))
|
||||
(syntax-case stx ()
|
||||
[(_ name ([field ctc] ...) kwds ...)
|
||||
(let ([fields (syntax->list #'(field ...))])
|
||||
(unless (or (identifier? #'name)
|
||||
(syntax-case #'name ()
|
||||
[(x y) (and (identifier? #'x)
|
||||
(identifier? #'y))]
|
||||
[_ #f]))
|
||||
(syntax-error "expected identifier for struct name or a sub-type relationship (subtype supertype)"
|
||||
#'name))
|
||||
(let* ([field-infos (map check-field fields (syntax->list #'(ctc ...)))]
|
||||
[sinfo (check-kwds (syntax->list #'(kwds ...)) field-infos)]
|
||||
[names (build-struct-names #'name field-infos)]
|
||||
[pred (car (cddddr names))]
|
||||
[ctcs (build-contracts stx pred field-infos)]
|
||||
[super-refs (let ([super (cadr names)])
|
||||
(if (identifier? super)
|
||||
(let ([v (syntax-local-value super (lambda () #f))])
|
||||
(unless (struct-info? v)
|
||||
(raise-syntax-error #f "identifier is not bound to a structure type"
|
||||
stx super))
|
||||
(let ([v (extract-struct-info v)])
|
||||
(cadddr v)))
|
||||
null))]
|
||||
[super-muts (let ([super (cadr names)])
|
||||
(if (identifier? super)
|
||||
(let ([v (syntax-local-value super (lambda () #f))])
|
||||
(unless (struct-info? v)
|
||||
(raise-syntax-error #f "identifier is not bound to a structure type"
|
||||
stx super))
|
||||
(let ([v (extract-struct-info v)])
|
||||
(car (cddddr v))))
|
||||
null))])
|
||||
(let-values ([(non-auto-fields auto-fields)
|
||||
(let loop ([fields field-infos]
|
||||
[nautos null]
|
||||
[autos null])
|
||||
(if (null? fields)
|
||||
(values (reverse nautos)
|
||||
(reverse autos))
|
||||
(if (field-info-auto? (car fields))
|
||||
(loop (cdr fields)
|
||||
nautos
|
||||
(cons (car fields) autos))
|
||||
(if (null? autos)
|
||||
(loop (cdr fields)
|
||||
(cons (car fields) nautos)
|
||||
autos)
|
||||
(syntax-error "non-auto field after auto fields"
|
||||
(field-info-stx (car fields)))))))])
|
||||
(with-syntax ([ctc-bindings
|
||||
(if (s-info-def-vals? sinfo)
|
||||
(map list (cdddr names)
|
||||
ctcs)
|
||||
null)]
|
||||
[orig stx]
|
||||
[struct-name (car names)]
|
||||
[(auto-check ...)
|
||||
(let* ([av-stx (if (s-info-auto-value-stx sinfo)
|
||||
(s-info-auto-value-stx sinfo)
|
||||
#'#f)]
|
||||
[av-id (datum->syntax av-stx
|
||||
(string->symbol
|
||||
(string-append (symbol->string (syntax-e (car names)))
|
||||
":auto-value"))
|
||||
av-stx)])
|
||||
(for/list ([finfo auto-fields])
|
||||
#`(let ([#,av-id #,av-stx])
|
||||
(contract #,(field-info-ctc finfo)
|
||||
#,av-id
|
||||
'(struct #,(car names))
|
||||
'cant-happen
|
||||
(quote #,av-id)
|
||||
(quote-srcloc #,av-id)))))]
|
||||
;; a list of variables, one for each super field
|
||||
[(super-field ...) (generate-temporaries super-refs)]
|
||||
;; the contract for a super field is any/c because the
|
||||
;; super constructor will have its own contract
|
||||
[(super-contract ...) (for/list ([i (in-list super-refs)])
|
||||
(datum->syntax stx 'any/c))]
|
||||
[(non-auto-contracts ...)
|
||||
(map field-info-ctc
|
||||
(filter (lambda (f)
|
||||
(not (field-info-auto? f)))
|
||||
field-infos))]
|
||||
[(struct: maker pred (ref ...) (mut ...) super)
|
||||
(let-values ([(refs muts)
|
||||
(let loop ([names (cdr (cddddr names))]
|
||||
[infos field-infos]
|
||||
[refs null]
|
||||
[muts null])
|
||||
(cond
|
||||
[(null? names)
|
||||
;; Don't reverse
|
||||
(values refs muts)]
|
||||
[(field-info-mutable? (car infos))
|
||||
(loop (cddr names)
|
||||
(cdr infos)
|
||||
(cons (car names) refs)
|
||||
(cons (cadr names) muts))]
|
||||
[else
|
||||
(loop (cdr names)
|
||||
(cdr infos)
|
||||
(cons (car names) refs)
|
||||
(cons #f muts))]))])
|
||||
(list (caddr names)
|
||||
(cadddr names)
|
||||
(car (cddddr names))
|
||||
refs
|
||||
muts
|
||||
(cadr names)))]
|
||||
[(non-auto-name ...)
|
||||
(map field-info-stx non-auto-fields)])
|
||||
(with-syntax ([(stx-def ...)
|
||||
(let ([quoter
|
||||
(λ (s)
|
||||
(if (identifier? s)
|
||||
#`(quote-syntax #,s)
|
||||
#'#f))])
|
||||
(cond
|
||||
[(not (s-info-def-stxs? sinfo))
|
||||
null]
|
||||
[(s-info-def-vals? sinfo)
|
||||
(list
|
||||
#`(define-syntax struct-name
|
||||
(make-contract-struct-info
|
||||
(λ ()
|
||||
(list #,(quoter #'struct:)
|
||||
#,(quoter #'maker)
|
||||
#,(quoter #'pred)
|
||||
(list* #,@(map quoter (syntax->list #'(ref ...)))
|
||||
(list #,@(map quoter super-refs)))
|
||||
(list* #,@(map quoter (syntax->list #'(mut ...)))
|
||||
(list #,@(map quoter super-muts)))
|
||||
#,(quoter #'super)))
|
||||
(λ () #,(quoter #'maker)))))]
|
||||
[else
|
||||
(list
|
||||
#'(define-syntax struct-name
|
||||
(make-struct-info
|
||||
(λ ()
|
||||
(list #f #f #f
|
||||
(list #f) (list #f)
|
||||
#,(quoter #'super))))))]))]
|
||||
[(omit-stx-def ...)
|
||||
(if (s-info-def-stxs? sinfo)
|
||||
(list '#:omit-define-syntaxes)
|
||||
null)])
|
||||
|
||||
(syntax/loc stx
|
||||
(begin
|
||||
(define-values () (begin auto-check ... (values)))
|
||||
stx-def ...
|
||||
(define (guard super-field ... non-auto-name ... struct-name)
|
||||
(values super-field ... non-auto-name ...))
|
||||
(define blame-id
|
||||
(current-contract-region))
|
||||
(with-contract #:region struct struct-name
|
||||
ctc-bindings
|
||||
(define-struct/derived orig name (field ...)
|
||||
omit-stx-def ...
|
||||
kwds ...
|
||||
#:guard (contract (-> super-contract ... non-auto-contracts ... symbol? any)
|
||||
guard
|
||||
(current-contract-region) blame-id
|
||||
(quote maker)
|
||||
(quote-srcloc maker)))))))))))]
|
||||
[(_ name . bad-fields)
|
||||
(identifier? #'name)
|
||||
(syntax-error "expected a list of field name/contract pairs"
|
||||
#'bad-fields)]
|
||||
[(_ . body)
|
||||
(syntax-error "expected a structure name"
|
||||
#'body)]))
|
||||
(define syntax-error
|
||||
(lambda v
|
||||
(apply raise-syntax-error type v)))
|
||||
|
||||
(define (build-struct-names name supertype field-infos)
|
||||
(let ([name-str (symbol->string (syntax-e name))])
|
||||
(list*
|
||||
name
|
||||
supertype
|
||||
(datum->syntax
|
||||
name
|
||||
(string->symbol
|
||||
(string-append "struct:" name-str)))
|
||||
(datum->syntax
|
||||
name
|
||||
(string->symbol
|
||||
(cond [(equal? type 'define-struct/contract) (string-append "make-" name-str)]
|
||||
[(equal? type 'struct/contract) name-str])))
|
||||
(datum->syntax
|
||||
name
|
||||
(string->symbol
|
||||
(string-append name-str "?")))
|
||||
(apply append
|
||||
(for/list ([finfo field-infos])
|
||||
(let ([field-str (symbol->string (syntax-e (field-info-stx finfo)))])
|
||||
(cons (datum->syntax
|
||||
name
|
||||
(string->symbol
|
||||
(string-append name-str "-" field-str)))
|
||||
(if (field-info-mutable? finfo)
|
||||
(list (datum->syntax
|
||||
name
|
||||
(string->symbol
|
||||
(string-append "set-" name-str "-" field-str "!"))))
|
||||
null))))))))
|
||||
(define (process-struct-names names field-infos)
|
||||
(cond [(equal? type 'define-struct/contract) (build-struct-names (syntax-case (car names) ()
|
||||
[id (identifier? #'id) #'id]
|
||||
[(sub super) #'sub])
|
||||
(syntax-case (car names) ()
|
||||
[id (identifier? #'id) #'#f]
|
||||
[(sub super) #'super])
|
||||
field-infos)]
|
||||
[(equal? type 'struct/contract) (let* ([super-type (if (= (length names) 2)
|
||||
(car (syntax-e (syntax-case (cdr names) ()
|
||||
[id #'id])))
|
||||
#'#f)])
|
||||
(build-struct-names (syntax-case (car names) ()
|
||||
[id (identifier? #'id) #'id])
|
||||
super-type
|
||||
field-infos))]))
|
||||
|
||||
(define (build-contracts stx pred field-infos)
|
||||
(list* (syntax/loc stx any/c)
|
||||
(syntax/loc stx any/c)
|
||||
(apply append
|
||||
(for/list ([finfo field-infos])
|
||||
(let ([field-ctc (field-info-ctc finfo)])
|
||||
(cons (quasisyntax/loc stx
|
||||
(-> #,pred #,field-ctc))
|
||||
(if (field-info-mutable? finfo)
|
||||
(list
|
||||
(quasisyntax/loc stx
|
||||
(-> #,pred #,field-ctc void?)))
|
||||
null)))))))
|
||||
|
||||
(define (check-field f ctc)
|
||||
(let ([p-list (syntax->list f)])
|
||||
(if p-list
|
||||
(begin
|
||||
(when (null? p-list)
|
||||
(syntax-error "expected struct field" f))
|
||||
(unless (identifier? (car p-list))
|
||||
(syntax-error "expected identifier" f))
|
||||
(let loop ([rest (cdr p-list)]
|
||||
[mutable? #f]
|
||||
[auto? #f])
|
||||
(if (null? rest)
|
||||
(make-field-info (car p-list) ctc mutable? auto?)
|
||||
(let ([elem (syntax-e (car rest))])
|
||||
(if (keyword? elem)
|
||||
(cond
|
||||
[(eq? elem '#:mutable)
|
||||
(begin (when mutable?
|
||||
(syntax-error "redundant #:mutable"
|
||||
(car rest)))
|
||||
(loop (cdr rest) #t auto?))]
|
||||
[(eq? elem '#:auto)
|
||||
(begin (when auto?
|
||||
(syntax-error "redundant #:mutable"
|
||||
(car rest)))
|
||||
(loop (cdr rest) mutable? #t))]
|
||||
[else (syntax-error "expected #:mutable or #:auto"
|
||||
(car rest))])
|
||||
(syntax-error "expected #:mutable or #:auto"
|
||||
(car rest)))))))
|
||||
(if (identifier? f)
|
||||
(make-field-info f ctc #f #f)
|
||||
(syntax-error "expected struct field" f)))))
|
||||
(define (check-kwds kwd-list field-infos)
|
||||
(let loop ([kwds kwd-list]
|
||||
[auto-value-stx #f]
|
||||
[mutable? #f]
|
||||
[transparent? #f]
|
||||
[def-stxs? #t]
|
||||
[def-vals? #t])
|
||||
(if (null? kwds)
|
||||
(make-s-info auto-value-stx transparent? def-stxs? def-vals?)
|
||||
(let ([kwd (syntax-e (car kwds))])
|
||||
(when (not (keyword? kwd))
|
||||
(syntax-error "expected a keyword"
|
||||
(car kwds)))
|
||||
(cond
|
||||
[(eq? kwd '#:auto-value)
|
||||
(when (null? (cdr kwds))
|
||||
(syntax-error "expected a following expression"
|
||||
(car kwds)))
|
||||
(loop (cddr kwds) (cadr kwds)
|
||||
transparent? mutable? def-stxs? def-vals?)]
|
||||
;; let arbitrary properties through
|
||||
[(eq? kwd '#:property)
|
||||
(when (null? (cdr kwds))
|
||||
(syntax-error "expected a property"
|
||||
(car kwds)))
|
||||
(when (null? (cddr kwds))
|
||||
(syntax-error "expected a value for the property"
|
||||
(car kwds)))
|
||||
(loop (cdddr kwds) auto-value-stx
|
||||
mutable? transparent? def-stxs? def-vals?)]
|
||||
[(eq? kwd '#:mutable)
|
||||
(when mutable?
|
||||
(syntax-error "redundant #:mutable"
|
||||
(car kwds)))
|
||||
(for ([finfo field-infos])
|
||||
(set-field-info-mutable?! finfo #t))
|
||||
(loop (cdr kwds) auto-value-stx
|
||||
#t transparent? def-stxs? def-vals?)]
|
||||
[(eq? kwd '#:transparent)
|
||||
(when transparent?
|
||||
(syntax-error "redundant #:transparent"
|
||||
(car kwds)))
|
||||
(loop (cdr kwds) auto-value-stx
|
||||
mutable? #t def-stxs? def-vals?)]
|
||||
[(eq? kwd '#:omit-define-syntaxes)
|
||||
(when (not def-stxs?)
|
||||
(syntax-error "redundant #:omit-define-syntaxes"
|
||||
(car kwds)))
|
||||
(loop (cdr kwds) auto-value-stx
|
||||
transparent? mutable? #f def-vals?)]
|
||||
[(eq? kwd '#:omit-define-values)
|
||||
(when (not def-vals?)
|
||||
(syntax-error "redundant #:omit-define-values"
|
||||
(car kwds)))
|
||||
(loop (cdr kwds) auto-value-stx
|
||||
transparent? mutable? def-stxs? #f)]
|
||||
[else (syntax-error "unexpected keyword"
|
||||
(car kwds))])))))
|
||||
|
||||
(syntax-parse stx
|
||||
[(_ name ... ([field ctc] ...) kwds ...)
|
||||
(let ([fields (syntax->list #'(field ...))]
|
||||
[names (syntax->list #'(name ...))])
|
||||
(unless (and (> (length names) 0)
|
||||
(<= (length names) 2)
|
||||
(or (and (equal? type 'define-struct/contract) ;; requirements for define-struct/contract
|
||||
(= (length names) 1)
|
||||
(or (identifier? (car names))
|
||||
(syntax-case (car names) ()
|
||||
[(x y) (and (identifier? #'x)
|
||||
(identifier? #'y))]
|
||||
[_ #f])))
|
||||
(and (equal? type 'struct/contract) ;; requirements for struct/contract
|
||||
(andmap identifier? names))))
|
||||
(cond [(equal? type 'define-struct/contract)
|
||||
(syntax-error "expected identifier for struct name or a sub-type relationship (subtype supertype)"
|
||||
#'(name ...))]
|
||||
[(equal? type 'struct/contract)
|
||||
(syntax-error "expected identifier for struct name or a sub-type relationship"
|
||||
#'(name ...))]))
|
||||
(let* ([field-infos (map check-field fields (syntax->list #'(ctc ...)))]
|
||||
[sinfo (check-kwds (syntax->list #'(kwds ...)) field-infos)]
|
||||
[keyword-list (syntax->list #'(kwds ...))]
|
||||
[names (process-struct-names names field-infos)]
|
||||
[pred (car (cddddr names))]
|
||||
[ctcs (build-contracts stx pred field-infos)]
|
||||
[super (cadr names)]
|
||||
[super-refs (if (identifier? super)
|
||||
(let ([v (syntax-local-value super (lambda () #f))])
|
||||
(unless (struct-info? v)
|
||||
(raise-syntax-error #f "identifier is not bound to a structure type"
|
||||
stx super))
|
||||
(let ([v (extract-struct-info v)])
|
||||
(cadddr v)))
|
||||
null)]
|
||||
[super-muts (let ([super (cadr names)])
|
||||
(if (identifier? super)
|
||||
(let ([v (syntax-local-value super (lambda () #f))])
|
||||
(unless (struct-info? v)
|
||||
(raise-syntax-error #f "identifier is not bound to a structure type"
|
||||
stx super))
|
||||
(let ([v (extract-struct-info v)])
|
||||
(car (cddddr v))))
|
||||
null))])
|
||||
(let-values ([(non-auto-fields auto-fields)
|
||||
(let loop ([fields field-infos]
|
||||
[nautos null]
|
||||
[autos null])
|
||||
(if (null? fields)
|
||||
(values (reverse nautos)
|
||||
(reverse autos))
|
||||
(if (field-info-auto? (car fields))
|
||||
(loop (cdr fields)
|
||||
nautos
|
||||
(cons (car fields) autos))
|
||||
(if (null? autos)
|
||||
(loop (cdr fields)
|
||||
(cons (car fields) nautos)
|
||||
autos)
|
||||
(syntax-error "non-auto field after auto fields"
|
||||
(field-info-stx (car fields)))))))])
|
||||
(with-syntax ([ctc-bindings
|
||||
(if (s-info-def-vals? sinfo)
|
||||
(map list (cdddr names)
|
||||
ctcs)
|
||||
null)]
|
||||
[orig stx]
|
||||
[struct-name (car names)]
|
||||
[(auto-check ...)
|
||||
(let* ([av-stx (if (s-info-auto-value-stx sinfo)
|
||||
(s-info-auto-value-stx sinfo)
|
||||
#'#f)]
|
||||
[av-id (datum->syntax av-stx
|
||||
(string->symbol
|
||||
(string-append (symbol->string (syntax-e (car names)))
|
||||
":auto-value"))
|
||||
av-stx)])
|
||||
(for/list ([finfo auto-fields])
|
||||
#`(let ([#,av-id #,av-stx])
|
||||
(contract #,(field-info-ctc finfo)
|
||||
#,av-id
|
||||
'(struct #,(car names))
|
||||
'cant-happen
|
||||
(quote #,av-id)
|
||||
(quote-srcloc #,av-id)))))]
|
||||
;; a list of variables, one for each super field
|
||||
[(super-field ...) (generate-temporaries super-refs)]
|
||||
;; the contract for a super field is any/c because the
|
||||
;; super constructor will have its own contract
|
||||
[(super-contract ...) (for/list ([i (in-list super-refs)])
|
||||
(datum->syntax stx 'any/c))]
|
||||
[(non-auto-contracts ...)
|
||||
(map field-info-ctc
|
||||
(filter (lambda (f)
|
||||
(not (field-info-auto? f)))
|
||||
field-infos))]
|
||||
[(struct: maker pred (ref ...) (mut ...) super)
|
||||
(let-values ([(refs muts)
|
||||
(let loop ([names (cdr (cddddr names))]
|
||||
[infos field-infos]
|
||||
[refs null]
|
||||
[muts null])
|
||||
(cond
|
||||
[(null? names)
|
||||
;; Don't reverse
|
||||
(values refs muts)]
|
||||
[(field-info-mutable? (car infos))
|
||||
(loop (cddr names)
|
||||
(cdr infos)
|
||||
(cons (car names) refs)
|
||||
(cons (cadr names) muts))]
|
||||
[else
|
||||
(loop (cdr names)
|
||||
(cdr infos)
|
||||
(cons (car names) refs)
|
||||
(cons #f muts))]))])
|
||||
(list (caddr names)
|
||||
(cadddr names)
|
||||
(car (cddddr names))
|
||||
refs
|
||||
muts
|
||||
(cadr names)))]
|
||||
|
||||
[(non-auto-name ...)
|
||||
(map field-info-stx non-auto-fields)])
|
||||
(with-syntax ([struct-definition-field (let ([struct-def-name (car names)]
|
||||
[struct-super-name (cadr names)])
|
||||
(if (identifier? struct-super-name)
|
||||
(list struct-def-name struct-super-name)
|
||||
struct-def-name))]
|
||||
[(omit-stx-def ...)
|
||||
(if (s-info-def-stxs? sinfo)
|
||||
(list '#:omit-define-syntaxes)
|
||||
null)]
|
||||
[(constructor-name ...)
|
||||
(if (equal? type 'struct/contract)
|
||||
(list '#:constructor-name (car names))
|
||||
null)]
|
||||
[(return-values ...) (filter (lambda (syntax-object)
|
||||
(let ([syntax-datum (syntax->datum syntax-object)])
|
||||
(not (or (equal? #f syntax-datum)
|
||||
(equal? null syntax-datum)
|
||||
(equal? '(#f) syntax-datum)))))
|
||||
(append (list
|
||||
#'struct:
|
||||
#'pred)
|
||||
(syntax->list #'(ref ...))
|
||||
(syntax->list #'(mut ...))))]
|
||||
[(maker-value ...) (list #'maker)])
|
||||
|
||||
(with-syntax ([(temp-maker-name ...) (generate-temporaries #'(maker-value ...))])
|
||||
(with-syntax ([(stx-def ...)
|
||||
(let ([quoter
|
||||
(λ (s)
|
||||
(if (identifier? s)
|
||||
#`(quote-syntax #,s)
|
||||
#'#f))])
|
||||
(cond
|
||||
[(not (s-info-def-stxs? sinfo))
|
||||
null]
|
||||
[(s-info-def-vals? sinfo)
|
||||
(list
|
||||
#`(define-syntax struct-name
|
||||
(make-contract-struct-info
|
||||
(λ ()
|
||||
(list #,(quoter #'struct:)
|
||||
#,(quoter #'maker)
|
||||
#,(quoter #'pred)
|
||||
(list* #,@(map quoter (syntax->list #'(ref ...)))
|
||||
(list #,@(map quoter super-refs)))
|
||||
(list* #,@(map quoter (syntax->list #'(mut ...)))
|
||||
(list #,@(map quoter super-muts)))
|
||||
#,(quoter #'super)))
|
||||
(λ () (car (syntax->list #'(temp-maker-name ...)))))))]
|
||||
[else
|
||||
(list
|
||||
#'(define-syntax struct-name
|
||||
(make-struct-info
|
||||
(λ ()
|
||||
(list #f #f #f
|
||||
(list #f) (list #f)
|
||||
#,(quoter #'super))))))]))]
|
||||
[define-returned-value-temps (if (equal? type 'define-struct/contract)
|
||||
#`(define maker-value ... temp-maker-name ...)
|
||||
#`(void))])
|
||||
|
||||
(syntax/loc stx
|
||||
(begin
|
||||
(define-values () (begin auto-check ... (values)))
|
||||
(define (guard super-field ... non-auto-name ... struct-name)
|
||||
(values super-field ... non-auto-name ...))
|
||||
(define blame-id
|
||||
(current-contract-region))
|
||||
(define-values (temp-maker-name ... return-values ...) (let () (with-contract #:region struct struct-name
|
||||
ctc-bindings
|
||||
(define-struct/derived orig struct-definition-field (field ...)
|
||||
constructor-name ...
|
||||
omit-stx-def ...
|
||||
kwds ...
|
||||
#:guard (contract (-> super-contract ... non-auto-contracts ... symbol? any)
|
||||
guard
|
||||
(current-contract-region) blame-id
|
||||
(quote maker)
|
||||
(quote-srcloc maker))))
|
||||
(values maker-value ... return-values ...)))
|
||||
define-returned-value-temps
|
||||
stx-def ...)))))))))]
|
||||
[(_ name . bad-fields)
|
||||
(identifier? #'name)
|
||||
(syntax-error "expected a list of field name/contract pairs"
|
||||
#'bad-fields)]
|
||||
[(_ . body)
|
||||
(syntax-error "expected a structure name"
|
||||
#'body)]))]
|
||||
[def-struct-transformer (lambda (stx)
|
||||
(parse-syntax stx
|
||||
'define-struct/contract))]
|
||||
[struct-transformer (lambda (stx)
|
||||
(parse-syntax stx
|
||||
'struct/contract))])
|
||||
(values def-struct-transformer
|
||||
struct-transformer)))
|
||||
|
||||
;
|
||||
;
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user