diff --git a/collects/mzlib/contract.rkt b/collects/mzlib/contract.rkt index b5152e0..c8f9724 100644 --- a/collects/mzlib/contract.rkt +++ b/collects/mzlib/contract.rkt @@ -2,11 +2,13 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; -;; provide arrow contracts from our local copy +;; provide arrow contracts from our local copy (mostly) ;; (require "private/contract-arrow.rkt") (provide (all-from-out "private/contract-arrow.rkt")) +(require (only-in racket/contract unconstrained-domain->)) +(provide unconstrained-domain->) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; @@ -15,6 +17,18 @@ (require "private/contract-object.rkt") (provide (all-from-out "private/contract-object.rkt")) +(require (only-in racket/class + is-a?/c + implementation?/c + subclass?/c + mixin-contract + make-mixin-contract)) +(provide is-a?/c + implementation?/c + subclass?/c + mixin-contract + make-mixin-contract) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; ;; old-style define/contract @@ -54,13 +68,16 @@ racket/contract/private/basic-opters racket/contract/combinator) + +(define (build-flat-contract name pred) (make-predicate-contract name pred)) + (provide opt/c define-opt/c ;(all-from "private/contract-opt.rkt") (except-out (all-from-out racket/contract/private/ds) contract-struct) - (all-from-out racket/contract/private/base) - (all-from-out racket/contract/private/provide) + (all-from-out racket/contract/private/base + racket/contract/private/provide) (except-out (all-from-out racket/contract/private/misc) check-between/c string-len/c @@ -69,8 +86,17 @@ (rename-out [string-len/c string/len]) (except-out (all-from-out racket/contract/private/guts) check-flat-contract - check-flat-named-contract) - (all-from-out racket/contract/private/prop - racket/contract/private/blame - racket/contract/combinator)) - + check-flat-named-contract + make-predicate-contract) + (except-out (all-from-out racket/contract/private/blame) + make-blame) + (except-out (all-from-out racket/contract/private/prop) + chaperone-contract-struct? + contract-struct-first-order + contract-struct-name + contract-struct-projection + contract-struct-stronger? + contract-struct? + flat-contract-struct?) + (all-from-out racket/contract/combinator) + build-flat-contract) diff --git a/collects/mzlib/private/contract-arrow.rkt b/collects/mzlib/private/contract-arrow.rkt index 6471de6..6c40637 100644 --- a/collects/mzlib/private/contract-arrow.rkt +++ b/collects/mzlib/private/contract-arrow.rkt @@ -22,51 +22,12 @@ ->pp-rest case-> opt-> - opt->* - unconstrained-domain->) + opt->*) (define-struct contracted-function (proc ctc) #:property prop:procedure 0 #:property prop:contracted 1) -(define-syntax (unconstrained-domain-> stx) - (syntax-case stx () - [(_ rngs ...) - (with-syntax ([(rngs-x ...) (generate-temporaries #'(rngs ...))] - [(proj-x ...) (generate-temporaries #'(rngs ...))] - [(p-app-x ...) (generate-temporaries #'(rngs ...))] - [(res-x ...) (generate-temporaries #'(rngs ...))]) - #'(let ([rngs-x (coerce-contract 'unconstrained-domain-> rngs)] ...) - (let ([proj-x (contract-projection rngs-x)] ...) - (define name - (build-compound-type-name 'unconstrained-domain-> (contract-name rngs-x) ...)) - (define (proj wrapper) - (λ (blame) - (let* ([p-app-x (proj-x blame)] ... - [res-checker (λ (res-x ...) (values (p-app-x res-x) ...))]) - (λ (val) - (if (procedure? val) - (wrapper - val - (make-keyword-procedure - (λ (kwds kwd-vals . args) - (apply values res-checker kwd-vals args)) - (λ args - (apply values res-checker args))) - impersonator-prop:contracted ctc) - (raise-blame-error blame val "expected a procedure")))))) - (define ctc - (if (and (chaperone-contract? rngs-x) ...) - (make-chaperone-contract - #:name name - #:projection (proj chaperone-procedure) - #:first-order procedure?) - (make-contract - #:name name - #:projection (proj impersonate-procedure) - #:first-order procedure?))) - ctc)))])) - (define (build--> name doms doms-rest rngs kwds quoted-kwds rng-any? func) (let ([doms/c (map (λ (dom) (coerce-contract name dom)) doms)] [rngs/c (map (λ (rng) (coerce-contract name rng)) rngs)] diff --git a/collects/mzlib/private/contract-object.rkt b/collects/mzlib/private/contract-object.rkt index 57b9ee0..1a5840b 100644 --- a/collects/mzlib/private/contract-object.rkt +++ b/collects/mzlib/private/contract-object.rkt @@ -10,12 +10,7 @@ racket/contract/private/helpers "contract-arr-obj-helpers.rkt")) -(provide mixin-contract - make-mixin-contract - is-a?/c - subclass?/c - implementation?/c - object-contract) +(provide object-contract) (define-syntax object-contract (let () @@ -303,46 +298,4 @@ ctc))))])))) -(define (make-mixin-contract . %/<%>s) - ((and/c (flat-contract class?) - (apply and/c (map sub/impl?/c %/<%>s))) - . ->d . - subclass?/c)) -(define (subclass?/c %) - (unless (class? %) - (error 'subclass?/c "expected , given: ~e" %)) - (let ([name (object-name %)]) - (flat-named-contract - `(subclass?/c ,(or name 'unknown%)) - (lambda (x) (subclass? x %))))) - -(define (implementation?/c <%>) - (unless (interface? <%>) - (error 'implementation?/c "expected , given: ~e" <%>)) - (let ([name (object-name <%>)]) - (flat-named-contract - `(implementation?/c ,(or name 'unknown<%>)) - (lambda (x) (implementation? x <%>))))) - -(define (sub/impl?/c %/<%>) - (cond - [(interface? %/<%>) (implementation?/c %/<%>)] - [(class? %/<%>) (subclass?/c %/<%>)] - [else (error 'make-mixin-contract "unknown input ~e" %/<%>)])) - -(define (is-a?/c <%>) - (unless (or (interface? <%>) - (class? <%>)) - (error 'is-a?/c "expected or , given: ~e" <%>)) - (let ([name (object-name <%>)]) - (flat-named-contract - (cond - [name - `(is-a?/c ,name)] - [(class? <%>) - `(is-a?/c unknown%)] - [else `(is-a?/c unknown<%>)]) - (lambda (x) (is-a? x <%>))))) - -(define mixin-contract (class? . ->d . subclass?/c))