suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Conversion of struct/c to chaperones when appropriate.

Browse Source
This commit is contained in:
Stevie Strickland 2010-12-07 03:15:16 -05:00
parent bd0b8d9c9f
commit 10eb818f95
8 changed files with 279 additions and 76 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

7
collects/mzlib/contract.rkt
View File

@ -30,6 +30,13 @@
(require "private/contract-mutable.rkt")
(provide (all-from-out "private/contract-mutable.rkt"))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; old-style flat struct contracts
;;
(require "private/contract-struct.rkt")
(provide (all-from-out "private/contract-struct.rkt"))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;
;; provide everything from the racket/ implementation

75
collects/mzlib/private/contract-struct.rkt Normal file
View File

@ -0,0 +1,75 @@
#lang racket/base
(require (for-syntax racket/base
racket/contract/private/helpers
racket/struct-info)
racket/contract/private/guts)
(provide struct/c)
#|
as with copy-struct in struct.rkt, this first begin0
expansion "declares" that struct/c is an expression.
It prevents further expansion until the internal definition
context is sorted out.
|#
(define-syntax (struct/c stx)
(syntax-case stx ()
[(_ . args)
(with-syntax ([x (syntax/loc stx (do-struct/c . args))])
(syntax/loc stx (begin0 x)))]))
(define-syntax (do-struct/c stx)
(syntax-case stx ()
[(_ struct-name args ...)
(and (identifier? (syntax struct-name))
(struct-info? (syntax-local-value (syntax struct-name) (λ () #f))))
(with-syntax ([(ctc-x ...) (generate-temporaries (syntax (args ...)))]
[(ctc-name-x ...) (generate-temporaries (syntax (args ...)))]
[(ctc-pred-x ...) (generate-temporaries (syntax (args ...)))]
[(ctc-app-x ...) (generate-temporaries (syntax (args ...)))]
[(field-numbers ...)
(let loop ([i 0]
[l (syntax->list (syntax (args ...)))])
(cond
[(null? l) '()]
[else (cons i (loop (+ i 1) (cdr l)))]))]
[(type-desc-id
constructor-id
predicate-id
(rev-selector-id ...)
(mutator-id ...)
super-id)
(lookup-struct-info (syntax struct-name) stx)])
(unless (= (length (syntax->list (syntax (rev-selector-id ...))))
(length (syntax->list (syntax (args ...)))))
(raise-syntax-error 'struct/c
(format "expected ~a contracts because struct ~a has ~a fields"
(length (syntax->list (syntax (rev-selector-id ...))))
(syntax-e #'struct-name)
(length (syntax->list (syntax (rev-selector-id ...)))))
stx))
(with-syntax ([(selector-id ...) (reverse (syntax->list (syntax (rev-selector-id ...))))])
(syntax
(let ([ctc-x (coerce-contract 'struct/c args)] ...)
(unless predicate-id
(error 'struct/c "could not determine predicate for ~s" 'struct-name))
(unless (and selector-id ...)
(error 'struct/c "could not determine selectors for ~s" 'struct-name))
(unless (flat-contract? ctc-x)
(error 'struct/c "expected flat contracts as arguments, got ~e" args))
...
(let ([ctc-pred-x (flat-contract-predicate ctc-x)]
...
[ctc-name-x (contract-name ctc-x)]
...)
(build-flat-contract
(build-compound-type-name 'struct/c 'struct-name ctc-x ...)
(λ (val)
(and (predicate-id val)
(ctc-pred-x (selector-id val)) ...))))))))]
[(_ struct-name anything ...)
(raise-syntax-error 'struct/c "expected a struct identifier" stx (syntax struct-name))]))

7
collects/mzlib/scribblings/contract.scrbl
View File

@ -81,7 +81,6 @@ from @schememodname[scheme/contract]:
real-in
recursive-contract
string/len
struct/c
symbols
syntax/c
vector-immutable/c
@ -124,3 +123,9 @@ flat contract that recognizes vectors. The number of elements in the
vector must match the number of arguments supplied to
@racket[vector/c], and each element of the vector must match the
corresponding flat contract.}
@defform[(struct/c struct-id flat-contract-expr ...)]{
Produces a flat contract that recognizes instances of the structure
type named by @racket[struct-id], and whose field values match the
flat contracts produced by the @racket[flat-contract-expr]s.}

2
collects/racket/contract/base.rkt
View File

@ -9,6 +9,7 @@
"private/box.rkt"
"private/hash.rkt"
"private/vector.rkt"
"private/struct.rkt"
"private/misc.rkt"
"private/provide.rkt"
"private/guts.rkt"
@ -31,6 +32,7 @@
(all-from-out "private/box.rkt")
(all-from-out "private/hash.rkt")
(all-from-out "private/vector.rkt")
(all-from-out "private/struct.rkt")
(except-out (all-from-out "private/misc.rkt")
check-between/c
check-unary-between/c)

70
collects/racket/contract/private/misc.rkt
View File

@ -1,7 +1,6 @@
#lang racket/base
(require (for-syntax racket/base
racket/struct-info
"helpers.rkt"
"opt-guts.rkt")
racket/promise
@ -22,7 +21,6 @@
symbols one-of/c
listof non-empty-listof cons/c list/c
promise/c
struct/c
syntax/c
check-between/c
@ -1022,74 +1020,6 @@
(delay (p-app (force val))))))
#:first-order promise?))))
#|
as with copy-struct in struct.rkt, this first begin0
expansion "declares" that struct/c is an expression.
It prevents further expansion until the internal definition
context is sorted out.
|#
(define-syntax (struct/c stx)
(syntax-case stx ()
[(_ . args)
(with-syntax ([x (syntax/loc stx (do-struct/c . args))])
(syntax/loc stx (begin0 x)))]))
(define-syntax (do-struct/c stx)
(syntax-case stx ()
[(_ struct-name args ...)
(and (identifier? (syntax struct-name))
(struct-info? (syntax-local-value (syntax struct-name) (λ () #f))))
(with-syntax ([(ctc-x ...) (generate-temporaries (syntax (args ...)))]
[(ctc-name-x ...) (generate-temporaries (syntax (args ...)))]
[(ctc-pred-x ...) (generate-temporaries (syntax (args ...)))]
[(ctc-app-x ...) (generate-temporaries (syntax (args ...)))]
[(field-numbers ...)
(let loop ([i 0]
[l (syntax->list (syntax (args ...)))])
(cond
[(null? l) '()]
[else (cons i (loop (+ i 1) (cdr l)))]))]
[(type-desc-id
constructor-id
predicate-id
(rev-selector-id ...)
(mutator-id ...)
super-id)
(lookup-struct-info (syntax struct-name) stx)])
(unless (= (length (syntax->list (syntax (rev-selector-id ...))))
(length (syntax->list (syntax (args ...)))))
(raise-syntax-error 'struct/c
(format "expected ~a contracts because struct ~a has ~a fields"
(length (syntax->list (syntax (rev-selector-id ...))))
(syntax-e #'struct-name)
(length (syntax->list (syntax (rev-selector-id ...)))))
stx))
(with-syntax ([(selector-id ...) (reverse (syntax->list (syntax (rev-selector-id ...))))])
(syntax
(let ([ctc-x (coerce-contract 'struct/c args)] ...)
(unless predicate-id
(error 'struct/c "could not determine predicate for ~s" 'struct-name))
(unless (and selector-id ...)
(error 'struct/c "could not determine selectors for ~s" 'struct-name))
(unless (flat-contract? ctc-x)
(error 'struct/c "expected flat contracts as arguments, got ~e" args))
...
(let ([ctc-pred-x (flat-contract-predicate ctc-x)]
...
[ctc-name-x (contract-name ctc-x)]
...)
(build-flat-contract
(build-compound-type-name 'struct/c 'struct-name ctc-x ...)
(λ (val)
(and (predicate-id val)
(ctc-pred-x (selector-id val)) ...))))))))]
[(_ struct-name anything ...)
(raise-syntax-error 'struct/c "expected a struct identifier" stx (syntax struct-name))]))
(define/subexpression-pos-prop (parameter/c x)
(make-parameter/c (coerce-contract 'parameter/c x)))

105
collects/racket/contract/private/struct.rkt Normal file
View File

@ -0,0 +1,105 @@
#lang racket/base
(require (for-syntax racket/base
racket/struct-info
"helpers.rkt")
"guts.rkt")
(provide struct/c)
#|
as with copy-struct in struct.rkt, this first begin0
expansion "declares" that struct/c is an expression.
It prevents further expansion until the internal definition
context is sorted out.
|#
(define-syntax (struct/c stx)
(syntax-case stx ()
[(_ . args)
(with-syntax ([x (syntax/loc stx (do-struct/c . args))])
(syntax/loc stx (begin0 x)))]))
(define-syntax (do-struct/c stx)
(syntax-case stx ()
[(_ struct-name args ...)
(and (identifier? (syntax struct-name))
(struct-info? (syntax-local-value (syntax struct-name) (λ () #f))))
(with-syntax ([(ctc-x ...) (generate-temporaries (syntax (args ...)))]
[(ctc-name-x ...) (generate-temporaries (syntax (args ...)))]
[(ctc-pred-x ...) (generate-temporaries (syntax (args ...)))]
[(ctc-proj-x ...) (generate-temporaries (syntax (args ...)))]
[(ctc-pos-proj-x ...) (generate-temporaries (syntax (args ...)))]
[(ctc-neg-proj-x ...) (generate-temporaries (syntax (args ...)))]
[(ctc-app-x ...) (generate-temporaries (syntax (args ...)))]
[(field-numbers ...)
(let loop ([i 0]
[l (syntax->list (syntax (args ...)))])
(cond
[(null? l) '()]
[else (cons i (loop (+ i 1) (cdr l)))]))]
[(type-desc-id
constructor-id
predicate-id
(rev-selector-id ...)
(rev-mutator-id ...)
super-id)
(lookup-struct-info (syntax struct-name) stx)])
(unless (= (length (syntax->list (syntax (rev-selector-id ...))))
(length (syntax->list (syntax (args ...)))))
(raise-syntax-error 'struct/c
(format "expected ~a contracts because struct ~a has ~a fields"
(length (syntax->list (syntax (rev-selector-id ...))))
(syntax-e #'struct-name)
(length (syntax->list (syntax (rev-selector-id ...)))))
stx))
(with-syntax ([(selector-id ...) (reverse (syntax->list (syntax (rev-selector-id ...))))]
[(mutator-id ...) (reverse (syntax->list (syntax (rev-mutator-id ...))))])
(syntax
(let ([ctc-x (coerce-contract 'struct/c args)] ...)
(unless predicate-id
(error 'struct/c "could not determine predicate for ~s" 'struct-name))
(unless (and selector-id ...)
(error 'struct/c "could not determine selectors for ~s" 'struct-name))
(unless (chaperone-contract? ctc-x)
(error 'struct/c "expected chaperone contracts as arguments, got ~e" args))
...
(let* ([ctc-pred-x (contract-first-order ctc-x)]
...
[ctc-name-x (contract-name ctc-x)]
...
;; To have a flat contract result, all of the contracted fields must be immutable
;; and all the contracts must be flat.
[flat? (and (andmap not (list mutator-id ...))
(for/and ([c (in-list (list ctc-x ...))])
(flat-contract? c)))]
[fo-check (λ (val)
(and (predicate-id val)
(ctc-pred-x (selector-id val)) ...))])
(if flat?
(build-flat-contract
(build-compound-type-name 'struct/c 'struct-name ctc-x ...)
fo-check)
(make-chaperone-contract
#:name (build-compound-type-name 'struct/c 'struct-name ctc-x ...)
#:first-order fo-check
#:projection
(let ([ctc-proj-x (contract-projection ctc-x)] ...)
(λ (blame)
(let* ([swapped-blame (blame-swap blame)]
[ctc-pos-proj-x (ctc-proj-x blame)] ...
[ctc-neg-proj-x (ctc-proj-x swapped-blame)] ...)
(λ (val)
(unless (predicate-id val)
(raise-blame-error blame val "expected a <~a>, got ~v" struct-name val))
;; Do first order checks on values in case the struct doesn't adhere to them
;; at wrapping time
(ctc-pos-proj-x (selector-id val)) ...
(apply chaperone-struct val
(append (list* selector-id (λ (s v) (ctc-pos-proj-x v))
(if mutator-id
(list mutator-id (λ (s v) (ctc-neg-proj-x v)))
null)) ...)))))))))))))]
[(_ struct-name anything ...)
(raise-syntax-error 'struct/c "expected a struct identifier" stx (syntax struct-name))]))

12
collects/scribblings/reference/contracts.scrbl
View File

@ -1,3 +1,4 @@
#lang scribble/doc
@(require "mz.rkt")
@(require (for-label syntax/modcollapse))
@ -23,6 +24,7 @@ constraints.
racket/contract/private/box
racket/contract/private/hash
racket/contract/private/vector
racket/contract/private/struct
racket/contract/private/misc
racket/contract/private/provide)]
@ -343,11 +345,15 @@ Produces a flat contract that recognizes syntax objects whose
@racket[syntax-e] content matches @racket[c].}
@defform[(struct/c struct-id flat-contract-expr ...)]{
@defform[(struct/c struct-id chaperone-contract-expr ...)]{
Produces a flat contract that recognizes instances of the structure
Produces a contract that recognizes instances of the structure
type named by @racket[struct-id], and whose field values match the
@tech{flat contracts} produced by the @racket[flat-contract-expr]s.}
chaperone contracts produced by the @racket[chaperone-contract-expr]s.
If the fields are immutable and the @racket[chaperone-contract-expr]s evaluate
to flat contracts, a flat contract is produced. Otherwise, a chaperone
contract is produced.}
@defproc[(parameter/c [c contract?]) contract?]{

77
collects/tests/racket/contract-test.rktl
View File

@ -7946,6 +7946,67 @@
(make-s 1 (make-s 2 3))
'pos
'neg)))
(test/spec-passed
'struct/c6
'(let ()
(define-struct s (f))
(let ([v (contract (struct/c s (-> number? number?))
(make-s values)
'pos
'neg)])
((s-f v) 3))))
(test/neg-blame
'struct/c7
'(let ()
(define-struct s (f))
(let ([v (contract (struct/c s (-> number? number?))
(make-s values)
'pos
'neg)])
((s-f v) #f))))
(test/pos-blame
'struct/c8
'(let ()
(define-struct s (f))
(let ([v (contract (struct/c s (-> number? number?))
(make-s (λ (v) #f))
'pos
'neg)])
((s-f v) 3))))
(test/spec-passed
'struct/c9
'(let ()
(define-struct s (a b) #:mutable)
(let ([v (contract (struct/c s integer? boolean?)
(make-s 3 #t)
'pos
'neg)])
(set-s-a! v 4)
(set-s-b! v #t))))
(test/neg-blame
'struct/c10
'(let ()
(define-struct s (a b) #:mutable)
(let ([v (contract (struct/c s integer? boolean?)
(make-s 3 #t)
'pos
'neg)])
(set-s-a! v #f))))
(test/neg-blame
'struct/c11
'(let ()
(define-struct s (a [b #:mutable]))
(let ([v (contract (struct/c s integer? boolean?)
(make-s 3 #t)
'pos
'neg)])
(set-s-b! v 5))))
;
@ -8917,8 +8978,20 @@ so that propagation occurs.
(ctest #t flat-contract? (and/c (flat-contract number?)
(flat-contract integer?)))
(ctest #t flat-contract? (let ()
(define-struct s (a b))
(struct/c s any/c any/c)))
(define-struct s (a b))
(struct/c s any/c any/c)))
(ctest #t chaperone-contract? (let ()
(define-struct s (a b) #:mutable)
(struct/c s any/c any/c)))
(ctest #t chaperone-contract? (let ()
(define-struct s ([a #:mutable] b))
(struct/c s any/c any/c)))
(ctest #t chaperone-contract? (let ()
(define-struct s (a [b #:mutable]))
(struct/c s any/c any/c)))
(ctest #t chaperone-contract? (let ()
(define-struct s (f))
(struct/c s (-> number? any))))
;; Hash contracts with flat domain/range contracts
(ctest #t contract? (hash/c any/c any/c #:immutable #f))