added the racket/contract/combinator library,
and documented and adjusted these libraries:
racket/contract/base
racket/contract/exists
racket/contract/parametric (renamed from exists)
racket/contract/region
This commit is contained in:
Robby Findler
parent
6b7e844254
commit
21cbd9ad81
|
|
@ -51,7 +51,8 @@
|
|||
racket/contract/private/blame
|
||||
racket/contract/private/ds
|
||||
racket/contract/private/opt
|
||||
racket/contract/private/basic-opters)
|
||||
racket/contract/private/basic-opters
|
||||
racket/contract/combinator)
|
||||
|
||||
(provide
|
||||
opt/c define-opt/c ;(all-from "private/contract-opt.rkt")
|
||||
|
|
@ -70,5 +71,6 @@
|
|||
check-flat-contract
|
||||
check-flat-named-contract)
|
||||
(all-from-out racket/contract/private/prop
|
||||
racket/contract/private/blame))
|
||||
racket/contract/private/blame
|
||||
racket/contract/combinator))
|
||||
|
||||
|
|
|
|||
|
|
@ -428,7 +428,7 @@
|
|||
|
||||
(provide well-formed-set?)
|
||||
|
||||
(provide/contract (struct integer-set ((contents (flat-named-contract "integer-set-list" well-formed-set?))))
|
||||
(provide/contract (struct integer-set ((contents well-formed-set?)))
|
||||
(make-range
|
||||
(->i () ((i exact-integer?) (j (i) (and/c exact-integer? (>=/c i)))) [res integer-set?]))
|
||||
(rename merge union (integer-set? integer-set? . -> . integer-set?))
|
||||
|
|
|
|||
|
|
@ -2,7 +2,8 @@
|
|||
|
||||
(provide (all-defined-out))
|
||||
(require racket/contract/private/guts
|
||||
racket/contract/private/blame)
|
||||
racket/contract/private/blame
|
||||
racket/contract/private/misc)
|
||||
|
||||
(define empty-case-lambda/c
|
||||
(flat-named-contract '(case->)
|
||||
|
|
|
|||
|
|
@ -5,6 +5,7 @@
|
|||
(require (for-syntax scheme/base))
|
||||
(require (for-template scheme/base)
|
||||
(for-template racket/contract/private/guts
|
||||
racket/contract/private/misc
|
||||
racket/contract/private/prop
|
||||
racket/contract/private/blame)
|
||||
(for-template "contract-arr-checks.rkt"))
|
||||
|
|
|
|||
|
|
@ -4,6 +4,7 @@
|
|||
racket/contract/private/blame
|
||||
racket/contract/private/prop
|
||||
racket/contract/private/opt
|
||||
racket/contract/private/misc
|
||||
"contract-arr-checks.rkt")
|
||||
(require (for-syntax racket/base)
|
||||
(for-syntax racket/contract/private/opt-guts)
|
||||
|
|
|
|||
|
|
@ -5,7 +5,8 @@
|
|||
vector-immutableof vector-immutable/c)
|
||||
racket/contract/private/blame
|
||||
racket/contract/private/guts
|
||||
racket/contract/private/prop)
|
||||
racket/contract/private/prop
|
||||
racket/contract/private/misc)
|
||||
|
||||
(provide box/c box-immutable/c
|
||||
vector/c vectorof vector-immutableof vector-immutable/c)
|
||||
|
|
|
|||
|
|
@ -1,6 +1,7 @@
|
|||
#lang racket/base
|
||||
(require "contract-arrow.rkt"
|
||||
racket/contract/private/guts
|
||||
racket/contract/private/misc
|
||||
racket/contract/private/prop
|
||||
racket/private/class-internal
|
||||
"contract-arr-checks.rkt")
|
||||
|
|
|
|||
|
|
@ -3,7 +3,8 @@
|
|||
(require (for-syntax racket/base
|
||||
racket/contract/private/helpers
|
||||
racket/struct-info)
|
||||
racket/contract/private/guts)
|
||||
racket/contract/private/guts
|
||||
racket/contract/private/misc)
|
||||
|
||||
(provide struct/c)
|
||||
|
||||
|
|
|
|||
|
|
@ -9,6 +9,7 @@
|
|||
"unit-syntax.rkt")
|
||||
(for-meta 2 racket/base)
|
||||
racket/contract/base
|
||||
racket/contract/combinator
|
||||
"unit-utils.rkt"
|
||||
"unit-runtime.rkt")
|
||||
|
||||
|
|
|
|||
|
|
@ -17,6 +17,8 @@
|
|||
|
||||
(require mzlib/etc
|
||||
racket/contract/base
|
||||
racket/contract/region
|
||||
racket/contract/combinator
|
||||
scheme/stxparam
|
||||
syntax/location
|
||||
"private/unit-contract.rkt"
|
||||
|
|
|
|||
|
|
@ -1,19 +1,14 @@
|
|||
#lang racket/base
|
||||
|
||||
(require racket/contract/exists
|
||||
racket/contract/regions
|
||||
(require "contract/base.rkt"
|
||||
"contract/combinator.rkt"
|
||||
"contract/parametric.rkt"
|
||||
"contract/region.rkt"
|
||||
"contract/private/basic-opters.rkt"
|
||||
"contract/base.rkt"
|
||||
"contract/private/legacy.rkt"
|
||||
"contract/private/ds.rkt"
|
||||
"contract/private/parametric.rkt"
|
||||
"private/define-struct.rkt")
|
||||
|
||||
(provide (all-from-out "contract/base.rkt")
|
||||
(all-from-out "contract/private/parametric.rkt")
|
||||
(except-out (all-from-out racket/contract/exists) ∀∃?)
|
||||
(all-from-out racket/contract/regions)
|
||||
|
||||
(all-from-out "contract/private/legacy.rkt")
|
||||
(all-from-out "contract/private/ds.rkt"))
|
||||
|
||||
"contract/private/ds.rkt")
|
||||
(provide (all-from-out "contract/base.rkt"
|
||||
"contract/combinator.rkt"
|
||||
"contract/parametric.rkt"
|
||||
"contract/region.rkt"
|
||||
"contract/private/legacy.rkt"
|
||||
"contract/private/ds.rkt"))
|
||||
|
|
|
|||
|
|
@ -1,8 +1,5 @@
|
|||
#lang racket/base
|
||||
|
||||
;; A version of racket/contract without contract regions
|
||||
;; for use in the macro stepper
|
||||
|
||||
(require "private/arrow.rkt"
|
||||
"private/arr-i.rkt"
|
||||
"private/base.rkt"
|
||||
|
|
@ -13,7 +10,6 @@
|
|||
"private/misc.rkt"
|
||||
"private/provide.rkt"
|
||||
"private/guts.rkt"
|
||||
"private/blame.rkt"
|
||||
"private/prop.rkt"
|
||||
"private/opters.rkt" ;; required for effect to install the opters
|
||||
"private/opt.rkt")
|
||||
|
|
@ -30,30 +26,22 @@
|
|||
contracted-function-proc
|
||||
contracted-function-ctc
|
||||
make-contracted-function)
|
||||
(all-from-out "private/arr-i.rkt")
|
||||
(all-from-out "private/box.rkt")
|
||||
(all-from-out "private/hash.rkt")
|
||||
(all-from-out "private/vector.rkt")
|
||||
(all-from-out "private/struct.rkt")
|
||||
(all-from-out "private/arr-i.rkt"
|
||||
"private/box.rkt"
|
||||
"private/hash.rkt"
|
||||
"private/vector.rkt"
|
||||
"private/struct.rkt")
|
||||
(except-out (all-from-out "private/base.rkt")
|
||||
current-contract-region)
|
||||
(except-out (all-from-out "private/misc.rkt")
|
||||
check-between/c
|
||||
check-unary-between/c)
|
||||
(all-from-out "private/provide.rkt")
|
||||
(all-from-out "private/base.rkt")
|
||||
(except-out (all-from-out "private/guts.rkt")
|
||||
check-flat-contract
|
||||
check-flat-named-contract)
|
||||
|
||||
(except-out (all-from-out "private/blame.rkt") make-blame)
|
||||
|
||||
(except-out (all-from-out "private/prop.rkt")
|
||||
contract-struct-name
|
||||
contract-struct-first-order
|
||||
contract-struct-projection
|
||||
contract-struct-stronger?
|
||||
contract-struct?
|
||||
chaperone-contract-struct?
|
||||
flat-contract-struct?)
|
||||
|
||||
;; from private/opt.rkt:
|
||||
opt/c define-opt/c)
|
||||
opt/c define-opt/c
|
||||
|
||||
;; from private/guts.rkt
|
||||
has-contract?
|
||||
value-contract
|
||||
)
|
||||
|
|
|
|||
23
collects/racket/contract/combinator.rkt
Normal file
23
collects/racket/contract/combinator.rkt
Normal file
|
|
@ -0,0 +1,23 @@
|
|||
#lang racket/base
|
||||
(require "private/prop.rkt"
|
||||
"private/guts.rkt"
|
||||
"private/blame.rkt")
|
||||
|
||||
(provide
|
||||
(except-out (all-from-out "private/prop.rkt")
|
||||
contract-struct-name
|
||||
contract-struct-first-order
|
||||
contract-struct-projection
|
||||
contract-struct-stronger?
|
||||
contract-struct?
|
||||
chaperone-contract-struct?
|
||||
flat-contract-struct?)
|
||||
|
||||
(except-out (all-from-out "private/guts.rkt")
|
||||
check-flat-contract
|
||||
check-flat-named-contract
|
||||
make-predicate-contract
|
||||
has-contract?
|
||||
value-contract)
|
||||
|
||||
(except-out (all-from-out "private/blame.rkt") make-blame))
|
||||
6
collects/racket/contract/parametric.rkt
Normal file
6
collects/racket/contract/parametric.rkt
Normal file
|
|
@ -0,0 +1,6 @@
|
|||
#lang racket/base
|
||||
(require "private/exists.rkt"
|
||||
"private/parametric.rkt")
|
||||
(provide (all-from-out "private/parametric.rkt")
|
||||
(except-out (all-from-out "private/exists.rkt")
|
||||
∀∃?))
|
||||
|
|
@ -1,600 +0,0 @@
|
|||
#lang racket/base
|
||||
|
||||
(require "guts.rkt"
|
||||
"arrow.rkt"
|
||||
"opt.rkt"
|
||||
"blame.rkt"
|
||||
"prop.rkt"
|
||||
racket/stxparam
|
||||
|
||||
(for-syntax racket/base
|
||||
syntax/stx
|
||||
syntax/name
|
||||
"arr-i-parse.rkt"
|
||||
"opt-guts.rkt"
|
||||
"helpers.rkt"
|
||||
"arr-util.rkt"))
|
||||
|
||||
(provide ->i)
|
||||
|
||||
(define-for-syntax (make-this-parameters id)
|
||||
(if (syntax-parameter-value #'making-a-method)
|
||||
(list id)
|
||||
null))
|
||||
|
||||
;; parses everything after the mandatory and optional doms in a ->d contract
|
||||
(define-for-syntax (parse-leftover stx leftover)
|
||||
(let*-values ([(raw-optional-doms leftover)
|
||||
(syntax-case leftover ()
|
||||
[(kwd . leftover2)
|
||||
(keyword? (syntax-e #'kwd))
|
||||
(values '() leftover)]
|
||||
[(dep-range)
|
||||
(values '() leftover)]
|
||||
[(dep-range #:post . more)
|
||||
(values '() leftover)]
|
||||
[((opts ...) . rest)
|
||||
(values #'(opts ...) #'rest)]
|
||||
[_ (values '() leftover)])]
|
||||
[(id/rest-id leftover)
|
||||
(syntax-case leftover ()
|
||||
[(#:rest [id rest-expr] . leftover)
|
||||
(and (identifier? #'id)
|
||||
(not (keyword? (syntax-e #'rest-expr))))
|
||||
(values #'(id rest-expr) #'leftover)]
|
||||
[(#:rest [id (id2 ...) rest-expr] . leftover)
|
||||
(and (identifier? #'id)
|
||||
(andmap identifier? (syntax->list #'(id2 ...)))
|
||||
(not (keyword? (syntax-e #'rest-expr))))
|
||||
(values #'(id rest-expr) #'leftover)]
|
||||
[(#:rest something . leftover)
|
||||
(raise-syntax-error #f "expected id+ctc" stx #'something)]
|
||||
[_ (values #f leftover)])]
|
||||
[(pre-cond leftover)
|
||||
(syntax-case leftover ()
|
||||
[(#:pre (id ...) pre-cond . leftover)
|
||||
(values #'pre-cond #'leftover)]
|
||||
[_ (values #f leftover)])]
|
||||
[(range leftover)
|
||||
(syntax-case leftover ()
|
||||
[(range . leftover) (values #'range #'leftover)]
|
||||
[_
|
||||
(raise-syntax-error #f "expected a range expression, but found nothing" stx)])]
|
||||
[(post-cond leftover)
|
||||
(syntax-case leftover ()
|
||||
[(#:post (id ...) post-cond . leftover)
|
||||
(begin
|
||||
(syntax-case range (any)
|
||||
[any (raise-syntax-error #f "cannot have a #:post with any as the range" stx #'post-cond)]
|
||||
[_ (void)])
|
||||
(values #'post-cond #'leftover))]
|
||||
[_ (values #f leftover)])])
|
||||
(syntax-case leftover ()
|
||||
[()
|
||||
(values raw-optional-doms id/rest-id pre-cond range post-cond)]
|
||||
[_
|
||||
(raise-syntax-error #f "bad syntax" stx)])))
|
||||
|
||||
;; verify-->i-structure : syntax syntax -> syntax
|
||||
;; returns the second argument when it has the proper shape for the first two arguments to ->i
|
||||
;; otherwise, raises a syntax error.
|
||||
;; also: drops the extra identifiers in the ->i.
|
||||
(define-for-syntax (verify-->i-structure stx doms)
|
||||
(syntax-case doms ()
|
||||
[((regular ...) (kwd ...))
|
||||
(let ([check-pair-shape
|
||||
(λ (reg)
|
||||
(syntax-case reg ()
|
||||
[(id dom)
|
||||
(identifier? #'id)
|
||||
reg]
|
||||
[(a b)
|
||||
(raise-syntax-error #f "expected an identifier" stx #'a)]
|
||||
|
||||
[(id (id2 ...) dom)
|
||||
(and (identifier? #'id)
|
||||
(andmap identifier? (syntax->list #'(id2 ...))))
|
||||
#'(id dom)]
|
||||
[(id ids dom)
|
||||
(unless (identifier? #'id)
|
||||
(raise-syntax-error #f "expected an identifier" stx #'id))
|
||||
(raise-syntax-error #f "expected an sequence of identifiers" stx #'ids)]
|
||||
[_
|
||||
(raise-syntax-error #f "expected an identifier and a contract-expr" stx reg)]))])
|
||||
(list (map check-pair-shape (syntax->list #'(regular ...)))
|
||||
(map
|
||||
(λ (kwd)
|
||||
(syntax-case kwd ()
|
||||
[(kwd ps)
|
||||
#`(kwd #,(check-pair-shape #'ps))]))
|
||||
(syntax->list #'(kwd ...)))))]))
|
||||
|
||||
(define-for-syntax (make-this-transformer this-arg)
|
||||
(with-syntax ([this-arg this-arg])
|
||||
(make-set!-transformer
|
||||
(λ (sstx)
|
||||
(syntax-case sstx (set!)
|
||||
[(set! id arg)
|
||||
(raise-syntax-error #f
|
||||
"can't mutate this"
|
||||
sstx)]
|
||||
[id
|
||||
(identifier? #'id)
|
||||
(syntax/loc sstx this-arg)]
|
||||
[(id . args)
|
||||
(datum->syntax sstx (cons #'this-arg #'args) sstx)])))))
|
||||
|
||||
(define-for-syntax (find-pre/post-keywords stx)
|
||||
(let ([pre #f]
|
||||
[post #f])
|
||||
(let loop ([stx (syntax->list stx)])
|
||||
(cond
|
||||
[(syntax? stx)
|
||||
(loop (syntax-e stx))]
|
||||
[(pair? stx)
|
||||
(when (and (syntax? (car stx))
|
||||
(eq? (syntax-e (car stx))
|
||||
'#:pre))
|
||||
(set! pre (car stx)))
|
||||
(when (and (syntax? (car stx))
|
||||
(eq? (syntax-e (car stx))
|
||||
'#:post))
|
||||
(set! post (car stx)))
|
||||
(loop (cdr stx))]
|
||||
[else (void)]))
|
||||
(values pre post)))
|
||||
|
||||
(define-syntax (->i stx)
|
||||
(parse-->i stx)
|
||||
(printf "finished ->i parsing\n")
|
||||
(syntax-case stx ()
|
||||
[(_ (raw-mandatory-doms ...)
|
||||
.
|
||||
leftover)
|
||||
(let-values ([(raw-optional-doms id/rest pre-cond range post-cond) (parse-leftover stx #'leftover)]
|
||||
[(this->i) (gensym '->i)])
|
||||
(define (add-indy-prop stx)
|
||||
(syntax-property stx 'racket/contract:internal-contract (gensym '->i-boundary)))
|
||||
(with-syntax ([(([mandatory-regular-id mandatory-dom/no-prop] ... )
|
||||
([mandatory-kwd (mandatory-kwd-id mandatory-kwd-dom/no-prop)] ...))
|
||||
(verify-->i-structure stx (split-doms stx '->i #'(raw-mandatory-doms ...)))]
|
||||
[(([optional-regular-id optional-dom/no-prop] ...)
|
||||
([optional-kwd (optional-kwd-id optional-kwd-dom/no-prop)] ...))
|
||||
(verify-->i-structure stx (split-doms stx '->i raw-optional-doms))])
|
||||
(with-syntax ([(mandatory-dom ...) (map (λ (x) (add-indy-prop (syntax-property x 'racket/contract:negative-position this->i)))
|
||||
(syntax->list #'(mandatory-dom/no-prop ...)))]
|
||||
[(mandatory-kwd-dom ...) (map (λ (x) (add-indy-prop (syntax-property x 'racket/contract:negative-position this->i)))
|
||||
(syntax->list #'(mandatory-kwd-dom/no-prop ...)))]
|
||||
[(optional-dom ...) (map (λ (x) (add-indy-prop (syntax-property x 'racket/contract:negative-position this->i)))
|
||||
(syntax->list #'(optional-dom/no-prop ...)))]
|
||||
[(optional-kwd-dom ...) (map (λ (x) (syntax-property x 'racket/contract:negative-position this->i))
|
||||
(syntax->list #'(optional-kwd-dom/no-prop ...)))])
|
||||
(with-syntax ([((kwd kwd-id) ...)
|
||||
(sort-keywords
|
||||
stx
|
||||
(syntax->list
|
||||
#'((optional-kwd optional-kwd-id) ...
|
||||
(mandatory-kwd mandatory-kwd-id) ...)))]
|
||||
[(this-parameter ...)
|
||||
(make-this-parameters (if (syntax? (syntax-parameter-value #'making-a-method))
|
||||
(car (generate-temporaries '(this)))
|
||||
(datum->syntax stx 'this #f)))])
|
||||
(with-syntax ([(dom-params ...)
|
||||
#`(this-parameter ...
|
||||
mandatory-regular-id ...
|
||||
optional-regular-id ...
|
||||
#,@(if id/rest
|
||||
(with-syntax ([(id rst-ctc) id/rest])
|
||||
#'(id))
|
||||
#'())
|
||||
kwd-id ...)])
|
||||
(with-syntax ([((rng-params ...) rng-ctcs)
|
||||
(syntax-case range (any values)
|
||||
[(values ctc-pr ...)
|
||||
(with-syntax ([((id ctc/no-prop) ...)
|
||||
(map (lambda (x) (syntax-case x ()
|
||||
[[id ctc/no-prop] #'[id ctc/no-prop]]
|
||||
[[id (id2 ...) ctc/no-prop] #'[id ctc/no-prop]]
|
||||
[x (raise-syntax-error #f "expected binding pair" stx #'x)]))
|
||||
(syntax->list #'(ctc-pr ...)))])
|
||||
(with-syntax ([(ctc ...) (map (λ (x) (add-indy-prop (syntax-property x 'racket/contract:positive-position this->i)))
|
||||
(syntax->list #'(ctc/no-prop ...)))])
|
||||
#'((id ...) (ctc ...))))]
|
||||
[any #'(() #f)]
|
||||
[[id ctc]
|
||||
#`((id) (#,(add-indy-prop (syntax-property #'ctc 'racket/contract:positive-position this->i))))]
|
||||
[[id (id2 ...) ctc]
|
||||
#`((id) (#,(add-indy-prop (syntax-property #'ctc 'racket/contract:positive-position this->i))))]
|
||||
[x (raise-syntax-error #f "expected binding pair or any" stx #'x)])]
|
||||
[mtd? (and (syntax-parameter-value #'making-a-method) #t)])
|
||||
(let ([rng-underscores?
|
||||
(let ([is-underscore?
|
||||
(λ (x)
|
||||
(syntax-case x (_)
|
||||
[_ #t]
|
||||
[else #f]))])
|
||||
(cond
|
||||
[(andmap is-underscore? (syntax->list #'(rng-params ...)))
|
||||
#t]
|
||||
[(ormap (λ (x) (and (is-underscore? x) x))
|
||||
(syntax->list #'(rng-params ...)))
|
||||
=>
|
||||
(λ (id)
|
||||
(raise-syntax-error '->i
|
||||
"expected all of the identifiers to be underscores, or none of them to be"
|
||||
stx
|
||||
id))]
|
||||
[else #f]))])
|
||||
(let ([dup (check-duplicate-identifier
|
||||
(append (if rng-underscores?
|
||||
'()
|
||||
(syntax->list #'(rng-params ...)))
|
||||
(syntax->list #'(dom-params ...))))])
|
||||
(when dup
|
||||
(raise-syntax-error #f "duplicate identifier" stx dup)))
|
||||
#`(let-syntax ([parameterize-this
|
||||
(let ([old-param (syntax-parameter-value #'making-a-method)])
|
||||
(λ (stx)
|
||||
(syntax-case stx ()
|
||||
[(_ body) #'body]
|
||||
[(_ id body)
|
||||
(if (syntax? old-param)
|
||||
(with-syntax ([param old-param])
|
||||
(syntax/loc stx
|
||||
(syntax-parameterize
|
||||
([param (make-this-transformer #'id)])
|
||||
body)))
|
||||
#'body)])))])
|
||||
(syntax-parameterize
|
||||
((making-a-method #f))
|
||||
#,(syntax-property
|
||||
#`(build-->d mtd?
|
||||
(list (λ (dom-params ...)
|
||||
(parameterize-this this-parameter ... mandatory-dom)) ...)
|
||||
(list (λ (dom-params ...)
|
||||
(parameterize-this this-parameter ... optional-dom)) ...)
|
||||
(list (λ (dom-params ...)
|
||||
(parameterize-this this-parameter ... mandatory-kwd-dom)) ...)
|
||||
(list (λ (dom-params ...)
|
||||
(parameterize-this this-parameter ... optional-kwd-dom)) ...)
|
||||
#,(if id/rest
|
||||
(with-syntax ([(id rst-ctc) id/rest])
|
||||
#`(λ (dom-params ...)
|
||||
(parameterize-this this-parameter ... rst-ctc)))
|
||||
#f)
|
||||
#,(if pre-cond
|
||||
#`(λ (dom-params ...)
|
||||
(parameterize-this this-parameter ... #,pre-cond))
|
||||
#f)
|
||||
#,(syntax-case #'rng-ctcs ()
|
||||
[#f #f]
|
||||
[(ctc ...)
|
||||
(if rng-underscores?
|
||||
#'(box (list (λ (dom-params ...)
|
||||
(parameterize-this this-parameter ... ctc)) ...))
|
||||
#'(list (λ (rng-params ... dom-params ...)
|
||||
(parameterize-this this-parameter ... ctc)) ...))])
|
||||
#,(if post-cond
|
||||
#`(λ (rng-params ... dom-params ...)
|
||||
(parameterize-this this-parameter ... #,post-cond))
|
||||
#f)
|
||||
'(mandatory-kwd ...)
|
||||
'(optional-kwd ...)
|
||||
(λ (f)
|
||||
#,(add-name-prop
|
||||
(syntax-local-infer-name stx)
|
||||
#`(λ args (apply f args)))))
|
||||
'racket/contract:contract
|
||||
(let-values ([(pre-kwd post-kwd) (find-pre/post-keywords #'leftover)])
|
||||
(vector this->i
|
||||
;; the -> in the original input to this guy
|
||||
(let ([kwd (list (car (syntax-e stx)))])
|
||||
(if post-kwd
|
||||
(cons post-kwd kwd)
|
||||
kwd))
|
||||
(if pre-kwd
|
||||
(list pre-kwd)
|
||||
'())))))))))))))]))
|
||||
|
||||
(define ->d-tail-key (gensym '->d-tail-key))
|
||||
|
||||
(define (->d-proj ->d-stct)
|
||||
(let* ([opt-count (length (->d-optional-dom-ctcs ->d-stct))]
|
||||
[mandatory-count (+ (length (->d-mandatory-dom-ctcs ->d-stct))
|
||||
(if (->d-mtd? ->d-stct) 1 0))]
|
||||
[non-kwd-ctc-count (+ mandatory-count opt-count)]
|
||||
[arity
|
||||
(cond
|
||||
[(->d-rest-ctc ->d-stct)
|
||||
(make-arity-at-least mandatory-count)]
|
||||
[else
|
||||
(let loop ([i 0])
|
||||
(cond
|
||||
[(= i opt-count)
|
||||
(list (+ mandatory-count i))]
|
||||
[else
|
||||
(cons (+ mandatory-count i) (loop (+ i 1)))]))])])
|
||||
(λ (blame)
|
||||
(let ([this->d-id (gensym '->d-tail-key)])
|
||||
(λ (val)
|
||||
(check-procedure val
|
||||
(->d-mtd? ->d-stct)
|
||||
(length (->d-mandatory-dom-ctcs ->d-stct)) ;dom-length
|
||||
(length (->d-optional-dom-ctcs ->d-stct)) ; optionals-length
|
||||
(->d-mandatory-keywords ->d-stct)
|
||||
(->d-optional-keywords ->d-stct)
|
||||
blame)
|
||||
(let ([kwd-proc
|
||||
(λ (kwd-args kwd-arg-vals . raw-orig-args)
|
||||
(let* ([orig-args (if (->d-mtd? ->d-stct)
|
||||
(cdr raw-orig-args)
|
||||
raw-orig-args)]
|
||||
[this (and (->d-mtd? ->d-stct) (car raw-orig-args))]
|
||||
[dep-pre-args
|
||||
(build-dep-ctc-args non-kwd-ctc-count raw-orig-args (->d-rest-ctc ->d-stct)
|
||||
(->d-keywords ->d-stct) kwd-args kwd-arg-vals)]
|
||||
[thunk
|
||||
(λ ()
|
||||
(keyword-apply
|
||||
val
|
||||
kwd-args
|
||||
|
||||
;; contracted keyword arguments
|
||||
(let loop ([all-kwds (->d-keywords ->d-stct)]
|
||||
[kwd-ctcs (->d-keyword-ctcs ->d-stct)]
|
||||
[building-kwd-args kwd-args]
|
||||
[building-kwd-arg-vals kwd-arg-vals])
|
||||
(cond
|
||||
[(or (null? building-kwd-args) (null? all-kwds)) '()]
|
||||
[else (if (eq? (car all-kwds)
|
||||
(car building-kwd-args))
|
||||
(cons (invoke-dep-ctc (car kwd-ctcs) dep-pre-args (car building-kwd-arg-vals) (blame-swap blame))
|
||||
(loop (cdr all-kwds) (cdr kwd-ctcs) (cdr building-kwd-args) (cdr building-kwd-arg-vals)))
|
||||
(loop (cdr all-kwds) (cdr kwd-ctcs) building-kwd-args building-kwd-arg-vals))]))
|
||||
|
||||
(append
|
||||
;; this parameter (if necc.)
|
||||
(if (->d-mtd? ->d-stct)
|
||||
(list (car raw-orig-args))
|
||||
'())
|
||||
|
||||
;; contracted ordinary arguments
|
||||
(let loop ([args orig-args]
|
||||
[non-kwd-ctcs (append (->d-mandatory-dom-ctcs ->d-stct)
|
||||
(->d-optional-dom-ctcs ->d-stct))])
|
||||
(cond
|
||||
[(null? args)
|
||||
(if (->d-rest-ctc ->d-stct)
|
||||
(invoke-dep-ctc (->d-rest-ctc ->d-stct) dep-pre-args '() (blame-swap blame))
|
||||
'())]
|
||||
[(null? non-kwd-ctcs)
|
||||
(if (->d-rest-ctc ->d-stct)
|
||||
(invoke-dep-ctc (->d-rest-ctc ->d-stct) dep-pre-args args (blame-swap blame))
|
||||
|
||||
;; ran out of arguments, but don't have a rest parameter.
|
||||
;; procedure-reduce-arity (or whatever the new thing is
|
||||
;; going to be called) should ensure this doesn't happen.
|
||||
(error 'shouldnt\ happen))]
|
||||
[else (cons (invoke-dep-ctc (car non-kwd-ctcs) dep-pre-args (car args) (blame-swap blame))
|
||||
(loop (cdr args)
|
||||
(cdr non-kwd-ctcs)))])))))]
|
||||
[rng (let ([rng (->d-range ->d-stct)])
|
||||
(cond
|
||||
[(not rng) #f]
|
||||
[(box? rng)
|
||||
(map (λ (val) (apply val dep-pre-args))
|
||||
(unbox rng))]
|
||||
[else rng]))]
|
||||
[rng-underscore? (box? (->d-range ->d-stct))])
|
||||
(when (->d-pre-cond ->d-stct)
|
||||
(unless (apply (->d-pre-cond ->d-stct) dep-pre-args)
|
||||
(raise-blame-error (blame-swap blame)
|
||||
val
|
||||
"#:pre violation~a"
|
||||
(build-values-string ", argument" dep-pre-args))))
|
||||
(call-with-immediate-continuation-mark
|
||||
->d-tail-key
|
||||
(λ (first-mark)
|
||||
(cond
|
||||
[(and rng
|
||||
(not (and first-mark
|
||||
(eq? this->d-id (car first-mark))
|
||||
(andmap eq? raw-orig-args (cdr first-mark)))))
|
||||
(call-with-values
|
||||
(λ ()
|
||||
(with-continuation-mark ->d-tail-key (cons this->d-id raw-orig-args)
|
||||
(thunk)))
|
||||
(λ orig-results
|
||||
(let* ([range-count (length rng)]
|
||||
[post-args (append orig-results raw-orig-args)]
|
||||
[post-non-kwd-arg-count (+ non-kwd-ctc-count range-count)]
|
||||
[dep-post-args (build-dep-ctc-args post-non-kwd-arg-count
|
||||
post-args (->d-rest-ctc ->d-stct)
|
||||
(->d-keywords ->d-stct) kwd-args kwd-arg-vals)])
|
||||
(when (->d-post-cond ->d-stct)
|
||||
(unless (apply (->d-post-cond ->d-stct) dep-post-args)
|
||||
(raise-blame-error blame
|
||||
val
|
||||
"#:post violation~a~a"
|
||||
(build-values-string ", argument" dep-pre-args)
|
||||
(build-values-string (if (null? dep-pre-args)
|
||||
", result"
|
||||
"\n result")
|
||||
orig-results))))
|
||||
|
||||
(unless (= range-count (length orig-results))
|
||||
(raise-blame-error blame
|
||||
val
|
||||
"expected ~a results, got ~a"
|
||||
range-count
|
||||
(length orig-results)))
|
||||
(apply
|
||||
values
|
||||
(let loop ([results orig-results]
|
||||
[result-contracts rng])
|
||||
(cond
|
||||
[(null? result-contracts) '()]
|
||||
[else
|
||||
(cons
|
||||
(invoke-dep-ctc (car result-contracts)
|
||||
(if rng-underscore? #f dep-post-args)
|
||||
(car results)
|
||||
blame)
|
||||
(loop (cdr results) (cdr result-contracts)))]))))))]
|
||||
[else
|
||||
(thunk)])))))])
|
||||
(make-contracted-function
|
||||
(procedure-reduce-keyword-arity
|
||||
(make-keyword-procedure kwd-proc
|
||||
((->d-name-wrapper ->d-stct)
|
||||
(λ args
|
||||
(apply kwd-proc '() '() args))))
|
||||
|
||||
arity
|
||||
(->d-mandatory-keywords ->d-stct)
|
||||
(->d-keywords ->d-stct))
|
||||
->d-stct)))))))
|
||||
|
||||
(define (build-values-string desc dep-pre-args)
|
||||
(cond
|
||||
[(null? dep-pre-args) ""]
|
||||
[(null? (cdr dep-pre-args)) (format "~a was: ~e" desc (car dep-pre-args))]
|
||||
[else
|
||||
(apply
|
||||
string-append
|
||||
(format "~as were:" desc)
|
||||
(let loop ([lst dep-pre-args])
|
||||
(cond
|
||||
[(null? lst) '()]
|
||||
[else (cons (format "\n ~e" (car lst))
|
||||
(loop (cdr lst)))])))]))
|
||||
|
||||
;; invoke-dep-ctc : (...? -> ctc) (or/c #f (listof tst)) val pos-blame neg-blame src-info orig-src -> tst
|
||||
(define (invoke-dep-ctc dep-ctc dep-args val blame)
|
||||
(let ([ctc (coerce-contract '->d (if dep-args
|
||||
(apply dep-ctc dep-args)
|
||||
dep-ctc))])
|
||||
(((contract-projection ctc) blame) val)))
|
||||
|
||||
;; build-dep-ctc-args : number (listof any) boolean (listof keyword) (listof keyword) (listof any)
|
||||
(define (build-dep-ctc-args non-kwd-ctc-count args rest-arg? all-kwds supplied-kwds supplied-args)
|
||||
(append
|
||||
|
||||
;; ordinary args (possibly including `this' as the first element)
|
||||
(let loop ([count non-kwd-ctc-count]
|
||||
[args args])
|
||||
(cond
|
||||
[(zero? count)
|
||||
(if rest-arg?
|
||||
(list args)
|
||||
'())]
|
||||
[(null? args) (cons the-unsupplied-arg (loop (- count 1) null))]
|
||||
[else (cons (car args) (loop (- count 1) (cdr args)))]))
|
||||
|
||||
;; kwd args
|
||||
(let loop ([all-kwds all-kwds]
|
||||
[kwds supplied-kwds]
|
||||
[args supplied-args])
|
||||
(cond
|
||||
[(null? all-kwds) null]
|
||||
[else (let* ([kwd (car all-kwds)]
|
||||
[kwd-matches? (and (not (null? kwds)) (eq? (car kwds) kwd))])
|
||||
(if kwd-matches?
|
||||
(cons (car args) (loop (cdr all-kwds) (cdr kwds) (cdr args)))
|
||||
(cons the-unsupplied-arg (loop (cdr all-kwds) kwds args))))]))))
|
||||
|
||||
(define (build-->d mtd?
|
||||
mandatory-dom-ctcs optional-dom-ctcs
|
||||
mandatory-kwd-dom-ctcs optional-kwd-dom-ctcs
|
||||
rest-ctc pre-cond range post-cond
|
||||
mandatory-kwds optional-kwds
|
||||
name-wrapper)
|
||||
(let ([kwd/ctc-pairs (sort
|
||||
(map cons
|
||||
(append mandatory-kwds optional-kwds)
|
||||
(append mandatory-kwd-dom-ctcs optional-kwd-dom-ctcs))
|
||||
(λ (x y) (keyword<? (car x) (car y))))])
|
||||
(make-->d mtd?
|
||||
mandatory-dom-ctcs optional-dom-ctcs
|
||||
(map cdr kwd/ctc-pairs)
|
||||
rest-ctc pre-cond range post-cond
|
||||
(map car kwd/ctc-pairs)
|
||||
mandatory-kwds
|
||||
optional-kwds
|
||||
name-wrapper)))
|
||||
|
||||
;; in the struct type descriptions "d???" refers to the arguments (domain) of the function that
|
||||
;; is under the contract, and "dr???" refers to the arguments & the results of the function that
|
||||
;; is under the contract.
|
||||
;; the `box' in the range only serves to differentiate between range contracts that depend on
|
||||
;; both the domain and the range from those that depend only on the domain (and thus, those
|
||||
;; that can be applied early)
|
||||
(define-struct ->d (mtd? ;; boolean; indicates if this is a contract on a method, for error reporing purposes.
|
||||
mandatory-dom-ctcs ;; (listof (-> d??? ctc))
|
||||
optional-dom-ctcs ;; (listof (-> d??? ctc))
|
||||
keyword-ctcs ;; (listof (-> d??? ctc))
|
||||
rest-ctc ;; (or/c false/c (-> d??? ctc))
|
||||
pre-cond ;; (-> d??? boolean)
|
||||
range ;; (or/c false/c (listof (-> dr??? ctc)) (box (listof (-> r??? ctc))))
|
||||
post-cond ;; (-> dr??? boolean)
|
||||
keywords ;; (listof keywords) -- sorted by keyword<
|
||||
mandatory-keywords ;; (listof keywords) -- sorted by keyword<
|
||||
optional-keywords ;; (listof keywords) -- sorted by keyword<
|
||||
name-wrapper) ;; (-> proc proc)
|
||||
|
||||
#:omit-define-syntaxes
|
||||
|
||||
#:property prop:contract
|
||||
(build-contract-property
|
||||
#:projection ->d-proj
|
||||
#:name
|
||||
(λ (ctc)
|
||||
(let* ([counting-id 'x]
|
||||
[ids '(x y z w)]
|
||||
[next-id
|
||||
(λ ()
|
||||
(cond
|
||||
[(pair? ids)
|
||||
(begin0 (car ids)
|
||||
(set! ids (cdr ids)))]
|
||||
[(null? ids)
|
||||
(begin0
|
||||
(string->symbol (format "~a0" counting-id))
|
||||
(set! ids 1))]
|
||||
[else
|
||||
(begin0
|
||||
(string->symbol (format "~a~a" counting-id ids))
|
||||
(set! ids (+ ids 1)))]))])
|
||||
`(->i (,@(map (λ (x) `(,(next-id) ...)) (->d-mandatory-dom-ctcs ctc))
|
||||
,@(apply append (map (λ (kwd) (list kwd `(,(next-id) ...))) (->d-mandatory-keywords ctc))))
|
||||
(,@(map (λ (x) `(,(next-id) ...)) (->d-optional-dom-ctcs ctc))
|
||||
,@(apply append (map (λ (kwd) (list kwd `(,(next-id) ...))) (->d-optional-keywords ctc))))
|
||||
,@(if (->d-rest-ctc ctc)
|
||||
(list '#:rest (next-id) '...)
|
||||
'())
|
||||
,@(if (->d-pre-cond ctc)
|
||||
(list '#:pre '...)
|
||||
(list))
|
||||
,(let ([range (->d-range ctc)])
|
||||
(cond
|
||||
[(not range) 'any]
|
||||
[(box? range)
|
||||
(let ([range (unbox range)])
|
||||
(cond
|
||||
[(and (not (null? range))
|
||||
(null? (cdr range)))
|
||||
`[_ ...]]
|
||||
[else
|
||||
`(values ,@(map (λ (x) `(_ ...)) range))]))]
|
||||
[(and (not (null? range))
|
||||
(null? (cdr range)))
|
||||
`[,(next-id) ...]]
|
||||
[else
|
||||
`(values ,@(map (λ (x) `(,(next-id) ...)) range))]))
|
||||
,@(if (->d-post-cond ctc)
|
||||
(list '#:post '...)
|
||||
(list)))))
|
||||
|
||||
#:first-order (λ (ctc) (λ (x) #f))
|
||||
#:stronger (λ (this that) (eq? this that))))
|
||||
|
||||
|
|
@ -7,6 +7,8 @@
|
|||
[module-identifier-mapping-get free-identifier-mapping-get]
|
||||
[module-identifier-mapping-put! free-identifier-mapping-put!])
|
||||
(for-template racket/base
|
||||
"misc.rkt"
|
||||
"prop.rkt"
|
||||
"guts.rkt"))
|
||||
|
||||
#|
|
||||
|
|
|
|||
|
|
@ -4,6 +4,7 @@
|
|||
"prop.rkt"
|
||||
"guts.rkt"
|
||||
"opt.rkt"
|
||||
"misc.rkt"
|
||||
"blame.rkt"
|
||||
syntax/location
|
||||
(for-syntax racket/base
|
||||
|
|
|
|||
|
|
@ -21,6 +21,7 @@ v4 todo:
|
|||
(require "guts.rkt"
|
||||
"blame.rkt"
|
||||
"prop.rkt"
|
||||
"misc.rkt"
|
||||
racket/stxparam)
|
||||
(require (for-syntax racket/base)
|
||||
(for-syntax "helpers.rkt")
|
||||
|
|
|
|||
|
|
@ -20,7 +20,8 @@ improve method arity mismatch contract violation error messages?
|
|||
"guts.rkt"
|
||||
"blame.rkt"
|
||||
"prop.rkt"
|
||||
"arrow.rkt")
|
||||
"arrow.rkt"
|
||||
"misc.rkt")
|
||||
|
||||
(define-syntax-parameter current-contract-region
|
||||
(λ (stx) #'(quote-module-path)))
|
||||
|
|
|
|||
|
|
@ -3,7 +3,8 @@
|
|||
(require "guts.rkt"
|
||||
"blame.rkt"
|
||||
"opt.rkt"
|
||||
"base.rkt")
|
||||
"base.rkt"
|
||||
"misc.rkt")
|
||||
(require (for-syntax racket/base
|
||||
"opt-guts.rkt"))
|
||||
|
||||
|
|
|
|||
|
|
@ -3,7 +3,8 @@
|
|||
(require (for-syntax racket/base)
|
||||
"prop.rkt"
|
||||
"blame.rkt"
|
||||
"guts.rkt")
|
||||
"guts.rkt"
|
||||
"misc.rkt")
|
||||
|
||||
(provide box-immutable/c
|
||||
(rename-out [wrap-box/c box/c]))
|
||||
|
|
|
|||
|
|
@ -20,7 +20,8 @@ it around flattened out.
|
|||
(require "guts.rkt"
|
||||
"prop.rkt"
|
||||
"blame.rkt"
|
||||
"opt.rkt")
|
||||
"opt.rkt"
|
||||
"misc.rkt")
|
||||
(require (for-syntax scheme/base)
|
||||
(for-syntax "ds-helpers.rkt")
|
||||
(for-syntax "helpers.rkt")
|
||||
|
|
|
|||
|
|
@ -1,8 +1,8 @@
|
|||
#lang racket/base
|
||||
|
||||
(require "private/guts.rkt"
|
||||
"private/prop.rkt"
|
||||
"private/blame.rkt")
|
||||
(require "guts.rkt"
|
||||
"prop.rkt"
|
||||
"blame.rkt")
|
||||
|
||||
(provide new-∃/c
|
||||
new-∀/c
|
||||
|
|
@ -16,24 +16,8 @@
|
|||
coerce-chaperone-contracts
|
||||
coerce-contract/f
|
||||
|
||||
chaperone-contract?
|
||||
|
||||
flat-contract?
|
||||
flat-contract
|
||||
flat-contract-predicate
|
||||
flat-named-contract
|
||||
|
||||
build-compound-type-name
|
||||
|
||||
and/c
|
||||
any/c
|
||||
none/c
|
||||
make-none/c
|
||||
|
||||
contract?
|
||||
contract-name
|
||||
contract-projection
|
||||
|
||||
contract-stronger?
|
||||
|
||||
contract-first-order
|
||||
|
|
@ -47,11 +31,12 @@
|
|||
;; for opters
|
||||
check-flat-contract
|
||||
check-flat-named-contract
|
||||
any
|
||||
|
||||
;; helpers for adding properties that check syntax uses
|
||||
define/final-prop
|
||||
define/subexpression-pos-prop)
|
||||
define/subexpression-pos-prop
|
||||
|
||||
make-predicate-contract)
|
||||
|
||||
(define (has-contract? v)
|
||||
(or (has-prop:contracted? v)
|
||||
|
|
@ -79,9 +64,6 @@
|
|||
(define-values (impersonator-prop:contracted has-impersonator-prop:contracted? get-impersonator-prop:contracted)
|
||||
(make-impersonator-property 'impersonator-prop:contracted))
|
||||
|
||||
(define-syntax (any stx)
|
||||
(raise-syntax-error 'any "use of 'any' outside the range of an arrow contract" stx))
|
||||
|
||||
(define (contract-first-order c)
|
||||
(contract-struct-first-order
|
||||
(coerce-contract 'contract-first-order c)))
|
||||
|
|
@ -176,7 +158,7 @@
|
|||
[(number? x) (make-=-contract x)]
|
||||
[(or (regexp? x) (byte-regexp? x)) (make-regexp/c x)]
|
||||
[else #f]))
|
||||
|
||||
|
||||
(define-syntax (define/final-prop stx)
|
||||
(syntax-case stx ()
|
||||
[(_ header bodies ...)
|
||||
|
|
@ -253,181 +235,12 @@
|
|||
(list (car (syntax-e stx)))
|
||||
'()))))])))))]))
|
||||
|
||||
;
|
||||
;
|
||||
;
|
||||
;
|
||||
;
|
||||
; ; ;
|
||||
; ;;; ;;; ; ;; ;;;; ; ; ;;; ;;; ;;;;
|
||||
; ; ; ; ; ;; ; ; ;; ; ; ; ; ;
|
||||
; ; ; ; ; ; ; ; ; ; ;
|
||||
; ; ; ; ; ; ; ; ;;;; ; ;
|
||||
; ; ; ; ; ; ; ; ; ; ; ;
|
||||
; ; ; ; ; ; ; ; ; ; ; ; ; ;
|
||||
; ;;; ;;; ; ; ;; ; ;;;;; ;;; ;;
|
||||
;
|
||||
;
|
||||
;
|
||||
|
||||
(define (flat-contract-predicate x)
|
||||
(contract-struct-first-order
|
||||
(coerce-flat-contract 'flat-contract-predicate x)))
|
||||
|
||||
(define (flat-contract? x)
|
||||
(let ([c (coerce-contract/f x)])
|
||||
(and c
|
||||
(flat-contract-struct? c))))
|
||||
|
||||
(define (chaperone-contract? x)
|
||||
(let ([c (coerce-contract/f x)])
|
||||
(and c
|
||||
(chaperone-contract-struct? c))))
|
||||
|
||||
(define (contract-name ctc)
|
||||
(contract-struct-name
|
||||
(coerce-contract 'contract-name ctc)))
|
||||
|
||||
(define (contract? x) (and (coerce-contract/f x) #t))
|
||||
(define (contract-projection ctc)
|
||||
(contract-struct-projection
|
||||
(coerce-contract 'contract-projection ctc)))
|
||||
|
||||
(define (check-flat-contract predicate) (coerce-flat-contract 'flat-contract predicate))
|
||||
(define (flat-contract predicate) (coerce-flat-contract 'flat-contract predicate))
|
||||
(define (check-flat-named-contract predicate) (coerce-flat-contract 'flat-named-contract predicate))
|
||||
(define (flat-named-contract name predicate)
|
||||
(cond
|
||||
[(and (procedure? predicate)
|
||||
(procedure-arity-includes? predicate 1))
|
||||
(make-predicate-contract name predicate)]
|
||||
[(flat-contract? predicate)
|
||||
(make-predicate-contract name (flat-contract-predicate predicate))]
|
||||
[else
|
||||
(error 'flat-named-contract
|
||||
"expected a flat contract or procedure of arity 1 as second argument, got ~e"
|
||||
predicate)]))
|
||||
|
||||
;; build-compound-type-name : (union contract symbol) ... -> (-> sexp)
|
||||
(define (build-compound-type-name . fs)
|
||||
(for/list ([sub (in-list fs)])
|
||||
(if (contract-struct? sub) (contract-name sub) sub)))
|
||||
|
||||
(define (and-name ctc)
|
||||
(apply build-compound-type-name 'and/c (base-and/c-ctcs ctc)))
|
||||
|
||||
(define (and-first-order ctc)
|
||||
(let ([tests (map contract-first-order (base-and/c-ctcs ctc))])
|
||||
(λ (x) (for/and ([test (in-list tests)]) (test x)))))
|
||||
|
||||
(define (and-proj ctc)
|
||||
(let ([mk-pos-projs (map contract-projection (base-and/c-ctcs ctc))])
|
||||
(lambda (blame)
|
||||
(let ([projs (map (λ (c) (c blame)) mk-pos-projs)])
|
||||
(for/fold ([proj (car projs)])
|
||||
([p (in-list (cdr projs))])
|
||||
(λ (v) (p (proj v))))))))
|
||||
|
||||
(define (first-order-and-proj ctc)
|
||||
(λ (blame)
|
||||
(λ (val)
|
||||
(let loop ([predicates (first-order-and/c-predicates ctc)]
|
||||
[ctcs (base-and/c-ctcs ctc)])
|
||||
(cond
|
||||
[(null? predicates) val]
|
||||
[else
|
||||
(if ((car predicates) val)
|
||||
(loop (cdr predicates) (cdr ctcs))
|
||||
(raise-blame-error
|
||||
blame
|
||||
val
|
||||
"expected <~s>, given ~a, which isn't ~s"
|
||||
(contract-name ctc)
|
||||
val
|
||||
(contract-name (car ctcs))))])))))
|
||||
|
||||
(define (and-stronger? this that)
|
||||
(and (base-and/c? that)
|
||||
(let ([this-ctcs (base-and/c-ctcs this)]
|
||||
[that-ctcs (base-and/c-ctcs that)])
|
||||
(and (= (length this-ctcs) (length that-ctcs))
|
||||
(andmap contract-stronger?
|
||||
this-ctcs
|
||||
that-ctcs)))))
|
||||
|
||||
(define-struct base-and/c (ctcs))
|
||||
(define-struct (first-order-and/c base-and/c) (predicates)
|
||||
#:property prop:flat-contract
|
||||
(build-flat-contract-property
|
||||
#:projection first-order-and-proj
|
||||
#:name and-name
|
||||
#:first-order and-first-order
|
||||
#:stronger and-stronger?))
|
||||
(define-struct (chaperone-and/c base-and/c) ()
|
||||
#:property prop:chaperone-contract
|
||||
(build-chaperone-contract-property
|
||||
#:projection and-proj
|
||||
#:name and-name
|
||||
#:first-order and-first-order
|
||||
#:stronger and-stronger?))
|
||||
(define-struct (impersonator-and/c base-and/c) ()
|
||||
#:property prop:contract
|
||||
(build-contract-property
|
||||
#:projection and-proj
|
||||
#:name and-name
|
||||
#:first-order and-first-order
|
||||
#:stronger and-stronger?))
|
||||
(if (contract-struct? sub) (contract-struct-name sub) sub)))
|
||||
|
||||
|
||||
(define/subexpression-pos-prop (and/c . raw-fs)
|
||||
(let ([contracts (coerce-contracts 'and/c raw-fs)])
|
||||
(cond
|
||||
[(null? contracts) any/c]
|
||||
[(andmap flat-contract? contracts)
|
||||
(let ([preds (map flat-contract-predicate contracts)])
|
||||
(make-first-order-and/c contracts preds))]
|
||||
[(andmap chaperone-contract? contracts)
|
||||
(make-chaperone-and/c contracts)]
|
||||
[else (make-impersonator-and/c contracts)])))
|
||||
|
||||
(define (get-any-projection c) any-projection)
|
||||
(define (any-projection b) any-function)
|
||||
(define (any-function x) x)
|
||||
|
||||
(define (get-any? c) any?)
|
||||
(define (any? x) #t)
|
||||
|
||||
(define-struct any/c ()
|
||||
#:omit-define-syntaxes
|
||||
#:property prop:flat-contract
|
||||
(build-flat-contract-property
|
||||
#:projection get-any-projection
|
||||
#:stronger (λ (this that) (any/c? that))
|
||||
#:name (λ (ctc) 'any/c)
|
||||
#:first-order get-any?))
|
||||
|
||||
(define/final-prop any/c (make-any/c))
|
||||
|
||||
(define (none-curried-proj ctc)
|
||||
(λ (blame)
|
||||
(λ (val)
|
||||
(raise-blame-error
|
||||
blame
|
||||
val
|
||||
"~s accepts no values, given: ~e"
|
||||
(none/c-name ctc)
|
||||
val))))
|
||||
|
||||
(define-struct none/c (name)
|
||||
#:omit-define-syntaxes
|
||||
#:property prop:flat-contract
|
||||
(build-flat-contract-property
|
||||
#:projection none-curried-proj
|
||||
#:stronger (λ (this that) #t)
|
||||
#:name (λ (ctc) (none/c-name ctc))
|
||||
#:first-order (λ (ctc) (λ (val) #f))))
|
||||
|
||||
(define/final-prop none/c (make-none/c 'none/c))
|
||||
|
||||
|
||||
|
||||
|
|
@ -509,3 +322,6 @@
|
|||
(predicate-contract-pred that))))
|
||||
#:name (λ (ctc) (predicate-contract-name ctc))
|
||||
#:first-order (λ (ctc) (predicate-contract-pred ctc))))
|
||||
|
||||
(define (check-flat-named-contract predicate) (coerce-flat-contract 'flat-named-contract predicate))
|
||||
(define (check-flat-contract predicate) (coerce-flat-contract 'flat-contract predicate))
|
||||
|
|
|
|||
|
|
@ -3,7 +3,8 @@
|
|||
(require (for-syntax racket/base)
|
||||
"guts.rkt"
|
||||
"blame.rkt"
|
||||
"prop.rkt")
|
||||
"prop.rkt"
|
||||
"misc.rkt")
|
||||
|
||||
(provide (rename-out [wrap-hash/c hash/c]))
|
||||
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
#lang racket/base
|
||||
|
||||
(require "guts.rkt" "blame.rkt" "prop.rkt" syntax/srcloc)
|
||||
(require "guts.rkt" "blame.rkt" "prop.rkt" "misc.rkt" syntax/srcloc)
|
||||
|
||||
(provide make-proj-contract
|
||||
raise-contract-error
|
||||
|
|
|
|||
|
|
@ -10,6 +10,7 @@
|
|||
(provide flat-rec-contract
|
||||
flat-murec-contract
|
||||
or/c
|
||||
and/c
|
||||
not/c
|
||||
=/c >=/c <=/c </c >/c between/c
|
||||
integer-in
|
||||
|
|
@ -25,7 +26,23 @@
|
|||
|
||||
check-between/c
|
||||
check-unary-between/c
|
||||
parameter/c)
|
||||
parameter/c
|
||||
|
||||
any/c
|
||||
any
|
||||
none/c
|
||||
make-none/c
|
||||
|
||||
chaperone-contract?
|
||||
flat-contract?
|
||||
contract?
|
||||
|
||||
flat-contract
|
||||
flat-contract-predicate
|
||||
flat-named-contract
|
||||
|
||||
contract-projection
|
||||
contract-name)
|
||||
|
||||
(define-syntax (flat-rec-contract stx)
|
||||
(syntax-case stx ()
|
||||
|
|
@ -280,6 +297,85 @@
|
|||
#:first-order
|
||||
(λ (ctc) (flat-or/c-pred ctc))))
|
||||
|
||||
|
||||
(define (and-name ctc)
|
||||
(apply build-compound-type-name 'and/c (base-and/c-ctcs ctc)))
|
||||
|
||||
(define (and-first-order ctc)
|
||||
(let ([tests (map contract-first-order (base-and/c-ctcs ctc))])
|
||||
(λ (x) (for/and ([test (in-list tests)]) (test x)))))
|
||||
|
||||
(define (and-proj ctc)
|
||||
(let ([mk-pos-projs (map contract-projection (base-and/c-ctcs ctc))])
|
||||
(lambda (blame)
|
||||
(let ([projs (map (λ (c) (c blame)) mk-pos-projs)])
|
||||
(for/fold ([proj (car projs)])
|
||||
([p (in-list (cdr projs))])
|
||||
(λ (v) (p (proj v))))))))
|
||||
|
||||
(define (first-order-and-proj ctc)
|
||||
(λ (blame)
|
||||
(λ (val)
|
||||
(let loop ([predicates (first-order-and/c-predicates ctc)]
|
||||
[ctcs (base-and/c-ctcs ctc)])
|
||||
(cond
|
||||
[(null? predicates) val]
|
||||
[else
|
||||
(if ((car predicates) val)
|
||||
(loop (cdr predicates) (cdr ctcs))
|
||||
(raise-blame-error
|
||||
blame
|
||||
val
|
||||
"expected <~s>, given ~a, which isn't ~s"
|
||||
(contract-name ctc)
|
||||
val
|
||||
(contract-name (car ctcs))))])))))
|
||||
|
||||
(define (and-stronger? this that)
|
||||
(and (base-and/c? that)
|
||||
(let ([this-ctcs (base-and/c-ctcs this)]
|
||||
[that-ctcs (base-and/c-ctcs that)])
|
||||
(and (= (length this-ctcs) (length that-ctcs))
|
||||
(andmap contract-stronger?
|
||||
this-ctcs
|
||||
that-ctcs)))))
|
||||
|
||||
(define-struct base-and/c (ctcs))
|
||||
(define-struct (first-order-and/c base-and/c) (predicates)
|
||||
#:property prop:flat-contract
|
||||
(build-flat-contract-property
|
||||
#:projection first-order-and-proj
|
||||
#:name and-name
|
||||
#:first-order and-first-order
|
||||
#:stronger and-stronger?))
|
||||
(define-struct (chaperone-and/c base-and/c) ()
|
||||
#:property prop:chaperone-contract
|
||||
(build-chaperone-contract-property
|
||||
#:projection and-proj
|
||||
#:name and-name
|
||||
#:first-order and-first-order
|
||||
#:stronger and-stronger?))
|
||||
(define-struct (impersonator-and/c base-and/c) ()
|
||||
#:property prop:contract
|
||||
(build-contract-property
|
||||
#:projection and-proj
|
||||
#:name and-name
|
||||
#:first-order and-first-order
|
||||
#:stronger and-stronger?))
|
||||
|
||||
|
||||
(define/subexpression-pos-prop (and/c . raw-fs)
|
||||
(let ([contracts (coerce-contracts 'and/c raw-fs)])
|
||||
(cond
|
||||
[(null? contracts) any/c]
|
||||
[(andmap flat-contract? contracts)
|
||||
(let ([preds (map flat-contract-predicate contracts)])
|
||||
(make-first-order-and/c contracts preds))]
|
||||
[(andmap chaperone-contract? contracts)
|
||||
(make-chaperone-and/c contracts)]
|
||||
[else (make-impersonator-and/c contracts)])))
|
||||
|
||||
|
||||
(define false/c #f)
|
||||
|
||||
(define/final-prop (string-len/c n)
|
||||
|
|
@ -358,28 +454,6 @@
|
|||
(let ([elems (one-of/c-elems ctc)])
|
||||
(λ (x) (memv x elems))))))
|
||||
|
||||
(define printable/c
|
||||
(flat-named-contract
|
||||
'printable/c
|
||||
(λ (x)
|
||||
(let printable? ([x x])
|
||||
(or (symbol? x)
|
||||
(string? x)
|
||||
(bytes? x)
|
||||
(boolean? x)
|
||||
(char? x)
|
||||
(null? x)
|
||||
(number? x)
|
||||
(regexp? x)
|
||||
(prefab-struct-key x) ;; this cannot be last, since it doesn't return just #t
|
||||
(and (pair? x)
|
||||
(printable? (car x))
|
||||
(printable? (cdr x)))
|
||||
(and (vector? x)
|
||||
(andmap printable? (vector->list x)))
|
||||
(and (box? x)
|
||||
(printable? (unbox x))))))))
|
||||
|
||||
(define-struct between/c (low high)
|
||||
#:omit-define-syntaxes
|
||||
#:property prop:flat-contract
|
||||
|
|
@ -446,15 +520,6 @@
|
|||
`(>/c ,x)
|
||||
(λ (y) (and (real? y) (> y x)))))
|
||||
|
||||
(define natural-number/c
|
||||
(flat-named-contract
|
||||
'natural-number/c
|
||||
(λ (x)
|
||||
(and (number? x)
|
||||
(integer? x)
|
||||
(exact? x)
|
||||
(x . >= . 0)))))
|
||||
|
||||
(define/final-prop (integer-in start end)
|
||||
(unless (and (integer? start)
|
||||
(exact? start)
|
||||
|
|
@ -703,3 +768,118 @@
|
|||
(parameter/c-ctc that))
|
||||
(contract-stronger? (parameter/c-ctc that)
|
||||
(parameter/c-ctc this))))))
|
||||
|
||||
|
||||
|
||||
(define (get-any-projection c) any-projection)
|
||||
(define (any-projection b) any-function)
|
||||
(define (any-function x) x)
|
||||
|
||||
(define (get-any? c) any?)
|
||||
(define (any? x) #t)
|
||||
|
||||
(define-struct any/c ()
|
||||
#:omit-define-syntaxes
|
||||
#:property prop:flat-contract
|
||||
(build-flat-contract-property
|
||||
#:projection get-any-projection
|
||||
#:stronger (λ (this that) (any/c? that))
|
||||
#:name (λ (ctc) 'any/c)
|
||||
#:first-order get-any?))
|
||||
|
||||
(define/final-prop any/c (make-any/c))
|
||||
|
||||
(define-syntax (any stx)
|
||||
(raise-syntax-error 'any "use of 'any' outside the range of an arrow contract" stx))
|
||||
|
||||
(define (none-curried-proj ctc)
|
||||
(λ (blame)
|
||||
(λ (val)
|
||||
(raise-blame-error
|
||||
blame
|
||||
val
|
||||
"~s accepts no values, given: ~e"
|
||||
(none/c-name ctc)
|
||||
val))))
|
||||
|
||||
(define-struct none/c (name)
|
||||
#:omit-define-syntaxes
|
||||
#:property prop:flat-contract
|
||||
(build-flat-contract-property
|
||||
#:projection none-curried-proj
|
||||
#:stronger (λ (this that) #t)
|
||||
#:name (λ (ctc) (none/c-name ctc))
|
||||
#:first-order (λ (ctc) (λ (val) #f))))
|
||||
|
||||
(define/final-prop none/c (make-none/c 'none/c))
|
||||
|
||||
|
||||
(define (flat-contract-predicate x)
|
||||
(contract-struct-first-order
|
||||
(coerce-flat-contract 'flat-contract-predicate x)))
|
||||
|
||||
(define (flat-contract? x)
|
||||
(let ([c (coerce-contract/f x)])
|
||||
(and c
|
||||
(flat-contract-struct? c))))
|
||||
|
||||
(define (chaperone-contract? x)
|
||||
(let ([c (coerce-contract/f x)])
|
||||
(and c
|
||||
(chaperone-contract-struct? c))))
|
||||
|
||||
(define (contract-name ctc)
|
||||
(contract-struct-name
|
||||
(coerce-contract 'contract-name ctc)))
|
||||
|
||||
(define (contract? x) (and (coerce-contract/f x) #t))
|
||||
(define (contract-projection ctc)
|
||||
(contract-struct-projection
|
||||
(coerce-contract 'contract-projection ctc)))
|
||||
|
||||
(define (flat-contract predicate) (coerce-flat-contract 'flat-contract predicate))
|
||||
(define (flat-named-contract name predicate)
|
||||
(cond
|
||||
[(and (procedure? predicate)
|
||||
(procedure-arity-includes? predicate 1))
|
||||
(make-predicate-contract name predicate)]
|
||||
[(flat-contract? predicate)
|
||||
(make-predicate-contract name (flat-contract-predicate predicate))]
|
||||
[else
|
||||
(error 'flat-named-contract
|
||||
"expected a flat contract or procedure of arity 1 as second argument, got ~e"
|
||||
predicate)]))
|
||||
|
||||
|
||||
|
||||
(define printable/c
|
||||
(flat-named-contract
|
||||
'printable/c
|
||||
(λ (x)
|
||||
(let printable? ([x x])
|
||||
(or (symbol? x)
|
||||
(string? x)
|
||||
(bytes? x)
|
||||
(boolean? x)
|
||||
(char? x)
|
||||
(null? x)
|
||||
(number? x)
|
||||
(regexp? x)
|
||||
(prefab-struct-key x) ;; this cannot be last, since it doesn't return just #t
|
||||
(and (pair? x)
|
||||
(printable? (car x))
|
||||
(printable? (cdr x)))
|
||||
(and (vector? x)
|
||||
(andmap printable? (vector->list x)))
|
||||
(and (box? x)
|
||||
(printable? (unbox x))))))))
|
||||
|
||||
|
||||
(define natural-number/c
|
||||
(flat-named-contract
|
||||
'natural-number/c
|
||||
(λ (x)
|
||||
(and (number? x)
|
||||
(integer? x)
|
||||
(exact? x)
|
||||
(x . >= . 0)))))
|
||||
|
|
|
|||
|
|
@ -1,7 +1,8 @@
|
|||
#lang scheme/base
|
||||
#lang racket/base
|
||||
(require "arrow.rkt"
|
||||
"guts.rkt"
|
||||
"prop.rkt"
|
||||
"misc.rkt"
|
||||
racket/private/class-internal
|
||||
scheme/stxparam)
|
||||
|
||||
|
|
|
|||
|
|
@ -2,7 +2,8 @@
|
|||
(require syntax/private/boundmap ;; needs to be the private one, since the public one has contracts
|
||||
(for-template racket/base)
|
||||
(for-template "guts.rkt"
|
||||
"blame.rkt")
|
||||
"blame.rkt"
|
||||
"misc.rkt")
|
||||
(for-syntax racket/base))
|
||||
|
||||
(provide get-opter reg-opter! opter
|
||||
|
|
|
|||
|
|
@ -2,6 +2,7 @@
|
|||
(require "guts.rkt"
|
||||
"prop.rkt"
|
||||
"blame.rkt"
|
||||
"misc.rkt"
|
||||
racket/stxparam)
|
||||
(require (for-syntax racket/base)
|
||||
(for-syntax "opt-guts.rkt")
|
||||
|
|
|
|||
|
|
@ -4,6 +4,7 @@
|
|||
"guts.rkt"
|
||||
"arrow.rkt"
|
||||
"blame.rkt"
|
||||
"misc.rkt"
|
||||
(for-syntax racket/base
|
||||
syntax/stx
|
||||
"opt-guts.rkt"))
|
||||
|
|
|
|||
|
|
@ -2,6 +2,7 @@
|
|||
(require "guts.rkt"
|
||||
"prop.rkt"
|
||||
"blame.rkt"
|
||||
"misc.rkt"
|
||||
(for-syntax racket/base))
|
||||
(provide parametric->/c)
|
||||
|
||||
|
|
|
|||
|
|
@ -9,8 +9,9 @@
|
|||
(prefix-in a: "helpers.rkt"))
|
||||
"arrow.rkt"
|
||||
"base.rkt"
|
||||
racket/contract/exists
|
||||
"guts.rkt"
|
||||
"misc.rkt"
|
||||
"exists.rkt"
|
||||
(for-syntax unstable/dirs)
|
||||
syntax/location
|
||||
syntax/srcloc)
|
||||
|
|
|
|||
|
|
@ -6,7 +6,8 @@
|
|||
racket/list
|
||||
"guts.rkt"
|
||||
"blame.rkt"
|
||||
"prop.rkt")
|
||||
"prop.rkt"
|
||||
"misc.rkt")
|
||||
|
||||
(provide struct/c)
|
||||
|
||||
|
|
|
|||
|
|
@ -3,7 +3,8 @@
|
|||
(require (for-syntax racket/base)
|
||||
"guts.ss"
|
||||
"prop.rkt"
|
||||
"blame.rkt")
|
||||
"blame.rkt"
|
||||
"misc.rkt")
|
||||
|
||||
(provide (rename-out [wrap-vectorof vectorof]
|
||||
[wrap-vector/c vector/c])
|
||||
|
|
|
|||
|
|
@ -2,7 +2,8 @@
|
|||
|
||||
(provide define-struct/contract
|
||||
define/contract
|
||||
with-contract)
|
||||
with-contract
|
||||
current-contract-region)
|
||||
|
||||
(require (for-syntax racket/base
|
||||
racket/list
|
||||
|
|
@ -17,7 +18,8 @@
|
|||
syntax/location
|
||||
"private/arrow.rkt"
|
||||
"private/base.rkt"
|
||||
"private/guts.rkt")
|
||||
"private/guts.rkt"
|
||||
"private/misc.rkt")
|
||||
|
||||
;; These are useful for all below.
|
||||
|
||||
|
|
@ -121,9 +121,7 @@
|
|||
(or/c #f (-> dict? contract?))
|
||||
(or/c #f (-> dict? contract?))))
|
||||
|
||||
(define even-length-list/c
|
||||
(flat-named-contract 'even-length-list/c
|
||||
(lambda (l) (even? (length l)))))
|
||||
(define (even-length-list? l) (even? (length l)))
|
||||
|
||||
;; ----------------------------------------
|
||||
|
||||
|
|
@ -163,7 +161,7 @@
|
|||
(recursive-contract
|
||||
(or/c null
|
||||
(cons/c key/c (cons/c val/c args/c))))])
|
||||
(and/c even-length-list/c
|
||||
(and/c even-length-list?
|
||||
args/c)))]
|
||||
[_r void?])]
|
||||
[dict-set*
|
||||
|
|
@ -174,7 +172,7 @@
|
|||
(recursive-contract
|
||||
(or/c null
|
||||
(cons/c key/c (cons/c val/c args/c))))])
|
||||
(and/c even-length-list/c
|
||||
(and/c even-length-list?
|
||||
args/c)))]
|
||||
[_r dict?])]
|
||||
[dict-update!
|
||||
|
|
|
|||
|
|
@ -3,6 +3,7 @@
|
|||
(require (for-syntax racket/base)
|
||||
mzlib/etc
|
||||
racket/contract/base
|
||||
racket/contract/combinator
|
||||
(only-in racket/contract/private/arrow making-a-method)
|
||||
racket/list
|
||||
racket/stxparam
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
#lang scheme
|
||||
|
||||
(require racket/contract/exists)
|
||||
(require racket/contract/private/exists)
|
||||
|
||||
;; this code builds the list of predicates (in case it changes, this may need to be re-run)
|
||||
#;
|
||||
|
|
|
|||
|
|
@ -17,15 +17,30 @@ another. Programmers specify the behavior of a module's exports via
|
|||
@racket[provide/contract], and the contract system enforces those
|
||||
constraints.
|
||||
|
||||
@note-lib[racket/contract #:use-sources (racket/contract/private/ds
|
||||
racket/contract/private/base
|
||||
racket/contract/private/guts
|
||||
racket/contract/private/box
|
||||
racket/contract/private/hash
|
||||
racket/contract/private/vector
|
||||
racket/contract/private/struct
|
||||
racket/contract/private/misc
|
||||
racket/contract/private/provide)]
|
||||
@(define-syntax-rule
|
||||
(add-use-sources (x y ...))
|
||||
(x y ...
|
||||
#:use-sources
|
||||
(racket/contract/private/base
|
||||
racket/contract/private/misc
|
||||
racket/contract/private/provide
|
||||
racket/contract/private/guts
|
||||
racket/contract/private/prop
|
||||
racket/contract/private/blame
|
||||
racket/contract/private/ds
|
||||
racket/contract/private/opt
|
||||
racket/contract/private/basic-opters
|
||||
|
||||
racket/contract/private/box
|
||||
racket/contract/private/hash
|
||||
racket/contract/private/vector
|
||||
racket/contract/private/struct)))
|
||||
|
||||
@(define-syntax-rule
|
||||
(declare-exporting-ctc mod)
|
||||
(add-use-sources (declare-exporting mod racket/contract racket)))
|
||||
|
||||
@(add-use-sources @note-lib[racket/contract])
|
||||
|
||||
@deftech{Contracts} come in two forms: those constructed by the
|
||||
various operations listed in this section of the manual, and various
|
||||
|
|
@ -55,6 +70,7 @@ failed, and anything else to indicate it passed.}
|
|||
@; ----------------------------------------
|
||||
|
||||
@section{Data-structure Contracts}
|
||||
@declare-exporting-ctc[racket/contract/base]
|
||||
|
||||
A @deftech{flat contract} can be fully checked immediately for
|
||||
a given value.
|
||||
|
|
@ -428,60 +444,12 @@ Constructs a contract on a promise. The contract does not force the
|
|||
promise, but when the promise is forced, the contract checks that the
|
||||
result value meets the contract produced by @racket[expr].}
|
||||
|
||||
|
||||
@defproc[(new-∀/c [name symbol?]) contract?]{
|
||||
Constructs a new universal contract.
|
||||
|
||||
Universal contracts accept all values when in negative positions (e.g., function
|
||||
inputs) and wrap them in an opaque struct, hiding the precise value.
|
||||
In positive positions (e.g. function returns),
|
||||
a universal contract accepts only values that were previously accepted in negative positions (by checking
|
||||
for the wrappers).
|
||||
|
||||
The name is used to identify the contract in error messages.
|
||||
|
||||
For example, this contract:
|
||||
@racketblock[(let ([a (new-∃/c 'a)])
|
||||
(-> a a))]
|
||||
describes the identity function (or a non-terminating function)
|
||||
That is, the first use of the @racket[a] appears in a
|
||||
negative position and thus inputs to that function are wrapped with an opaque struct.
|
||||
Then, when the function returns, it is checked to determine whether the result is wrapped, since
|
||||
the second @racket[a] appears in a positive position.
|
||||
|
||||
The @racket[new-∀/c] construct constructor is dual to @racket[new-∃/c].
|
||||
|
||||
}
|
||||
|
||||
@defproc[(new-∃/c [name symbol?]) contract?]{
|
||||
Constructs a new existential contract.
|
||||
|
||||
Existential contracts accept all values when in positive positions (e.g., function
|
||||
returns) and wrap them in an opaque struct, hiding the precise value.
|
||||
In negative positions (e.g. function inputs),
|
||||
they accepts only values that were previously accepted in positive positions (by checking
|
||||
for the wrappers).
|
||||
|
||||
The name is used to identify the contract in error messages.
|
||||
|
||||
For example, this contract:
|
||||
@racketblock[(let ([a (new-∃/c 'a)])
|
||||
(-> (-> a a)
|
||||
any/c))]
|
||||
describes a function that accepts the identity function (or a non-terminating function)
|
||||
and returns an arbitrary value. That is, the first use of the @racket[a] appears in a
|
||||
positive position and thus inputs to that function are wrapped with an opaque struct.
|
||||
Then, when the function returns, it is checked to see if the result is wrapped, since
|
||||
the second @racket[a] appears in a negative position.
|
||||
|
||||
The @racket[new-∃/c] construct constructor is dual to @racket[new-∀/c].
|
||||
}
|
||||
|
||||
|
||||
@; ------------------------------------------------------------------------
|
||||
|
||||
@section{Function Contracts}
|
||||
|
||||
@declare-exporting-ctc[racket/contract/base]
|
||||
|
||||
A @deftech{function contract} wraps a procedure to delay
|
||||
checks for its arguments and results. There are three
|
||||
primary function contract combinators that have increasing
|
||||
|
|
@ -786,7 +754,15 @@ be blamed using the above contract:
|
|||
}
|
||||
|
||||
|
||||
@subsection[#:tag "parametric-contracts"]{Parametric Contracts}
|
||||
@section[#:tag "parametric-contracts"]{Parametric Contracts}
|
||||
@defmodule*/no-declare[(racket/contract/parametric)]
|
||||
@declare-exporting-ctc[racket/contract/parametric]
|
||||
|
||||
The most convenient way to use parametric contract is to use
|
||||
@racket[provide/contract]'s @racket[#:exists] keyword.
|
||||
The @racketmodname[racket/contract/parametric] provides a few more,
|
||||
general-purpose parametric contracts.
|
||||
|
||||
|
||||
@defform[(parametric->/c (x ...) c)]{
|
||||
|
||||
|
|
@ -815,6 +791,56 @@ if they do not, a contract violation is signaled.
|
|||
]
|
||||
}
|
||||
|
||||
@defproc[(new-∀/c [name symbol?]) contract?]{
|
||||
Constructs a new universal contract.
|
||||
|
||||
Universal contracts accept all values when in negative positions (e.g., function
|
||||
inputs) and wrap them in an opaque struct, hiding the precise value.
|
||||
In positive positions (e.g. function returns),
|
||||
a universal contract accepts only values that were previously accepted in negative positions (by checking
|
||||
for the wrappers).
|
||||
|
||||
The name is used to identify the contract in error messages.
|
||||
|
||||
For example, this contract:
|
||||
@racketblock[(let ([a (new-∀/c 'a)])
|
||||
(-> a a))]
|
||||
describes the identity function (or a non-terminating function)
|
||||
That is, the first use of the @racket[a] appears in a
|
||||
negative position and thus inputs to that function are wrapped with an opaque struct.
|
||||
Then, when the function returns, it is checked to determine whether the result is wrapped, since
|
||||
the second @racket[a] appears in a positive position.
|
||||
|
||||
The @racket[new-∀/c] construct constructor is dual to @racket[new-∃/c].
|
||||
|
||||
}
|
||||
|
||||
@defproc[(new-∃/c [name symbol?]) contract?]{
|
||||
Constructs a new existential contract.
|
||||
|
||||
Existential contracts accept all values when in positive positions (e.g., function
|
||||
returns) and wrap them in an opaque struct, hiding the precise value.
|
||||
In negative positions (e.g. function inputs),
|
||||
they accepts only values that were previously accepted in positive positions (by checking
|
||||
for the wrappers).
|
||||
|
||||
The name is used to identify the contract in error messages.
|
||||
|
||||
For example, this contract:
|
||||
@racketblock[(let ([a (new-∃/c 'a)])
|
||||
(-> (-> a a)
|
||||
any/c))]
|
||||
describes a function that accepts the identity function (or a non-terminating function)
|
||||
and returns an arbitrary value. That is, the first use of the @racket[a] appears in a
|
||||
positive position and thus inputs to that function are wrapped with an opaque struct.
|
||||
Then, when the function returns, it is checked to see if the result is wrapped, since
|
||||
the second @racket[a] appears in a negative position.
|
||||
|
||||
The @racket[new-∃/c] construct constructor is dual to @racket[new-∀/c].
|
||||
}
|
||||
|
||||
|
||||
|
||||
|
||||
@; ------------------------------------------------------------------------
|
||||
|
||||
|
|
@ -909,6 +935,7 @@ lazy contract.
|
|||
@; ------------------------------------------------------------------------
|
||||
|
||||
@section{Attaching Contracts to Values}
|
||||
@declare-exporting-ctc[racket/contract/base]
|
||||
|
||||
@defform/subs[
|
||||
#:literals (struct rename)
|
||||
|
|
@ -969,6 +996,10 @@ is bound to vectors of two elements, the exported identifier and a
|
|||
syntax object for the expression that produces the contract controlling
|
||||
the export.
|
||||
}
|
||||
|
||||
@subsection{Nested Contract Boundaries}
|
||||
@defmodule*/no-declare[(racket/contract/region)]
|
||||
@declare-exporting-ctc[racket/contract/region]
|
||||
|
||||
@defform*/subs[
|
||||
[(with-contract blame-id (wc-export ...) free-var-list ... body ...+)
|
||||
|
|
@ -1050,6 +1081,9 @@ The @racket[define-struct/contract] form only allows a subset of the
|
|||
(make-salmon #f 'pacific)
|
||||
]}
|
||||
|
||||
@subsection{Low-level Contract Boundaries}
|
||||
@declare-exporting-ctc[racket/contract/base]
|
||||
|
||||
@defform*[[(contract contract-expr to-protect-expr
|
||||
positive-blame-expr negative-blame-expr)
|
||||
(contract contract-expr to-protect-expr
|
||||
|
|
@ -1088,8 +1122,8 @@ accepted by the third argument to @racket[datum->syntax].
|
|||
|
||||
@section{Building New Contract Combinators}
|
||||
|
||||
@emph{@bold{Note:}
|
||||
The interface in this section is unstable and subject to change.}
|
||||
@defmodule*/no-declare[(racket/contract/combinator)]
|
||||
@declare-exporting-ctc[racket/contract/combinator]
|
||||
|
||||
Contracts are represented internally as functions that
|
||||
accept information about the contract (who is to blame,
|
||||
|
|
@ -1460,6 +1494,44 @@ specific to the precise violation.
|
|||
field extracts the @racket[blame?] object associated with a contract violation.
|
||||
}
|
||||
|
||||
@defparam[current-blame-format
|
||||
proc
|
||||
(-> blame? any/c string? string?)]{
|
||||
|
||||
A parameter that is used when constructing a
|
||||
contract violation error. Its value is procedure that
|
||||
accepts three arguments:
|
||||
@itemize[
|
||||
@item{the blame object for the violation,}
|
||||
@item{the value that the contract applies to, and}
|
||||
@item{a message indicating the kind of violation.}]
|
||||
The procedure then
|
||||
returns a string that is put into the contract error
|
||||
message. Note that the value is often already included in
|
||||
the message that indicates the violation.
|
||||
|
||||
@defexamples[#:eval (contract-eval)
|
||||
(define (show-blame-error blame value message)
|
||||
(string-append
|
||||
"Contract Violation!\n"
|
||||
(format "Guilty Party: ~a\n" (blame-positive blame))
|
||||
(format "Innocent Party: ~a\n" (blame-negative blame))
|
||||
(format "Contracted Value Name: ~a\n" (blame-value blame))
|
||||
(format "Contract Location: ~s\n" (blame-source blame))
|
||||
(format "Contract Name: ~a\n" (blame-contract blame))
|
||||
(format "Offending Value: ~s\n" value)
|
||||
(format "Offense: ~a\n" message)))
|
||||
(current-blame-format show-blame-error)
|
||||
(define/contract (f x)
|
||||
(-> integer? integer?)
|
||||
(/ x 2))
|
||||
(f 2)
|
||||
(f 1)
|
||||
(f 1/2)
|
||||
]
|
||||
|
||||
}
|
||||
|
||||
@subsection{Contracts as structs}
|
||||
|
||||
@para{
|
||||
|
|
@ -1727,46 +1799,8 @@ are below):
|
|||
|
||||
@; ------------------------------------------------------------------------
|
||||
|
||||
@section{Contract Utilities}
|
||||
|
||||
@defproc[(contract? [v any/c]) boolean?]{
|
||||
|
||||
Returns @racket[#t] if its argument is a contract (i.e., constructed
|
||||
with one of the combinators described in this section or a value that
|
||||
can be used as a contract) and @racket[#f] otherwise.}
|
||||
|
||||
@defproc[(chaperone-contract? [v any/c]) boolean?]{
|
||||
|
||||
Returns @racket[#t] if its argument is a contract that guarantees that
|
||||
it returns a value which passes @racket[chaperone-of?] when compared to
|
||||
the original, uncontracted value.}
|
||||
|
||||
@defproc[(flat-contract? [v any/c]) boolean?]{
|
||||
|
||||
Returns @racket[#t] when its argument is a contract that can be
|
||||
checked immediately (unlike, say, a function contract).
|
||||
|
||||
For example,
|
||||
@racket[flat-contract] constructs flat contracts from predicates, and
|
||||
symbols, booleans, numbers, and other ordinary Racket values
|
||||
(that are defined as @tech{contracts}) are also
|
||||
flat contracts.}
|
||||
|
||||
@defproc[(flat-contract-predicate [v flat-contract?])
|
||||
(any/c . -> . any/c)]{
|
||||
|
||||
Extracts the predicate from a flat contract.}
|
||||
|
||||
@defproc[(value-contract [v has-contract?]) contract?]{
|
||||
Returns the contract attached to @racket[v], if recorded.
|
||||
Otherwise it returns @racket[#f].
|
||||
}
|
||||
|
||||
@defproc[(has-contract? [v any/c]) boolean?]{
|
||||
Returns @racket[#t] if @racket[v] is a value that
|
||||
has a recorded contract attached to it.
|
||||
}
|
||||
|
||||
@subsection{Utilities for Building New Combinators}
|
||||
|
||||
@defproc[(contract-stronger? [x contract?] [y contract?]) boolean?]{
|
||||
Returns @racket[#t] if the contract @racket[x] accepts either fewer
|
||||
or the same number of values as @racket[y] does.
|
||||
|
|
@ -1799,14 +1833,57 @@ may or may not hold. If the contract is a first-order
|
|||
contract, a result of @racket[#t] guarantees that the
|
||||
contract holds.}
|
||||
|
||||
@defproc[(contract-name [c contract?]) any/c]{
|
||||
Produces the name used to describe the contract in error messages.
|
||||
}
|
||||
|
||||
@defproc[(contract-first-order [c contract?]) (-> any/c boolean?)]{
|
||||
Produces the first-order test used by @racket[or/c] to match values to
|
||||
higher-order contracts.
|
||||
}
|
||||
|
||||
@section{Contract Utilities}
|
||||
|
||||
@declare-exporting-ctc[racket/contract/base]
|
||||
|
||||
@defproc[(contract? [v any/c]) boolean?]{
|
||||
|
||||
Returns @racket[#t] if its argument is a contract (i.e., constructed
|
||||
with one of the combinators described in this section or a value that
|
||||
can be used as a contract) and @racket[#f] otherwise.}
|
||||
|
||||
@defproc[(chaperone-contract? [v any/c]) boolean?]{
|
||||
|
||||
Returns @racket[#t] if its argument is a contract that guarantees that
|
||||
it returns a value which passes @racket[chaperone-of?] when compared to
|
||||
the original, uncontracted value.}
|
||||
|
||||
@defproc[(flat-contract? [v any/c]) boolean?]{
|
||||
|
||||
Returns @racket[#t] when its argument is a contract that can be
|
||||
checked immediately (unlike, say, a function contract).
|
||||
|
||||
For example,
|
||||
@racket[flat-contract] constructs flat contracts from predicates, and
|
||||
symbols, booleans, numbers, and other ordinary Racket values
|
||||
(that are defined as @tech{contracts}) are also
|
||||
flat contracts.}
|
||||
|
||||
@defproc[(flat-contract-predicate [v flat-contract?])
|
||||
(any/c . -> . any/c)]{
|
||||
|
||||
Extracts the predicate from a flat contract.}
|
||||
|
||||
@defproc[(contract-name [c contract?]) any/c]{
|
||||
Produces the name used to describe the contract in error messages.
|
||||
}
|
||||
|
||||
@defproc[(value-contract [v has-contract?]) contract?]{
|
||||
Returns the contract attached to @racket[v], if recorded.
|
||||
Otherwise it returns @racket[#f].
|
||||
}
|
||||
|
||||
@defproc[(has-contract? [v any/c]) boolean?]{
|
||||
Returns @racket[#t] if @racket[v] is a value that
|
||||
has a recorded contract attached to it.
|
||||
}
|
||||
|
||||
|
||||
@defproc[(contract-projection [c contract?]) (-> blame? (-> any/c any/c))]{
|
||||
Produces the projection defining a contract's behavior on protected values.
|
||||
|
|
@ -1817,46 +1894,6 @@ Produces the projection defining a contract's behavior on protected values.
|
|||
Makes a contract that accepts no values, and reports the
|
||||
name @racket[sexp-name] when signaling a contract violation.}
|
||||
|
||||
|
||||
@defparam[current-blame-format
|
||||
proc
|
||||
(-> blame? any/c string? string?)]{
|
||||
|
||||
A parameter that is used when constructing a
|
||||
contract violation error. Its value is procedure that
|
||||
accepts three arguments:
|
||||
@itemize[
|
||||
@item{the blame object for the violation,}
|
||||
@item{the value that the contract applies to, and}
|
||||
@item{a message indicating the kind of violation.}]
|
||||
The procedure then
|
||||
returns a string that is put into the contract error
|
||||
message. Note that the value is often already included in
|
||||
the message that indicates the violation.
|
||||
|
||||
@defexamples[#:eval (contract-eval)
|
||||
(define (show-blame-error blame value message)
|
||||
(string-append
|
||||
"Contract Violation!\n"
|
||||
(format "Guilty Party: ~a\n" (blame-positive blame))
|
||||
(format "Innocent Party: ~a\n" (blame-negative blame))
|
||||
(format "Contracted Value Name: ~a\n" (blame-value blame))
|
||||
(format "Contract Location: ~s\n" (blame-source blame))
|
||||
(format "Contract Name: ~a\n" (blame-contract blame))
|
||||
(format "Offending Value: ~s\n" value)
|
||||
(format "Offense: ~a\n" message)))
|
||||
(current-blame-format show-blame-error)
|
||||
(define/contract (f x)
|
||||
(-> integer? integer?)
|
||||
(/ x 2))
|
||||
(f 2)
|
||||
(f 1)
|
||||
(f 1/2)
|
||||
]
|
||||
|
||||
}
|
||||
|
||||
|
||||
@defform*[[(recursive-contract contract-expr)
|
||||
(recursive-contract contract-expr type)]]{
|
||||
|
||||
|
|
@ -1963,4 +2000,4 @@ makes a binary search tree contract, but one that is
|
|||
struct and returns a projection function that checks the contract.
|
||||
|
||||
}
|
||||
|
||||
|
||||
|
|
|
|||
|
|
@ -1,5 +1,6 @@
|
|||
#lang racket/base
|
||||
(require racket/contract/base
|
||||
racket/contract/combinator
|
||||
syntax/location
|
||||
(for-syntax racket/base
|
||||
racket/syntax
|
||||
|
|
|
|||
|
|
@ -1,5 +1,6 @@
|
|||
#lang racket/base
|
||||
(require racket/contract/base
|
||||
racket/contract/combinator
|
||||
"../private/minimatch.rkt"
|
||||
"../private/keywords.rkt"
|
||||
"../private/runtime-reflect.rkt"
|
||||
|
|
|
|||
|
|
@ -195,12 +195,10 @@ Arguments is defined in rep-patterns.rkt
|
|||
|
||||
;; Contracts
|
||||
|
||||
(define DeclEnv/c
|
||||
(flat-named-contract 'DeclEnv declenv?))
|
||||
(define DeclEnv/c declenv?)
|
||||
|
||||
(define DeclEntry/c
|
||||
(flat-named-contract 'DeclEntry
|
||||
(or/c den:lit? den:class? den:parser? den:delayed?)))
|
||||
(define DeclEntry/c
|
||||
(or/c den:lit? den:class? den:parser? den:delayed?))
|
||||
|
||||
(define SideClause/c
|
||||
(or/c clause:fail? clause:with? clause:attr? clause:do?))
|
||||
|
|
|
|||
|
|
@ -4,7 +4,7 @@
|
|||
(for-template
|
||||
(except-in racket/base for for*)
|
||||
"prims.rkt"
|
||||
(prefix-in c: (combine-in racket/contract/regions racket/contract/base)))
|
||||
(prefix-in c: (combine-in racket/contract/region racket/contract/base)))
|
||||
"extra-procs.rkt" "prims.rkt"
|
||||
syntax/parse racket/block racket/match
|
||||
unstable/sequence "base-types-extra.rkt"
|
||||
|
|
|
|||
|
|
@ -1,5 +1,6 @@
|
|||
#lang racket/base
|
||||
(require racket/contract/base)
|
||||
(require racket/contract/base
|
||||
racket/contract/combinator)
|
||||
|
||||
(define (get-stpc-proj stpc)
|
||||
(let ([get-val-proj
|
||||
|
|
|
|||
|
|
@ -1,5 +1,4 @@
|
|||
#lang racket
|
||||
|
||||
(define-struct stuffer (in out))
|
||||
(define (stuffer/c dom rng)
|
||||
(define in (dom . -> . rng))
|
||||
|
|
|
|||
|
|
@ -1,4 +1,5 @@
|
|||
#lang racket
|
||||
#lang racket/base
|
||||
(require racket/contract)
|
||||
|
||||
; Location = (make-location Nat Nat Nat) | Symbol
|
||||
(define-struct location (line char offset) #:transparent)
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user