From b8fb6dae9a54d89389ebf282f4f15011dbef36b0 Mon Sep 17 00:00:00 2001 From: Stevie Strickland Date: Thu, 13 May 2010 14:20:39 -0400 Subject: [PATCH] Initially just move the box-related combinators to a new location. --- collects/mzlib/contract.rkt | 2 + collects/racket/contract/base.rkt | 2 + collects/racket/contract/private/box.rkt | 98 +++++++++++++++++++ collects/racket/contract/private/misc.rkt | 11 --- .../scribblings/reference/contracts.scrbl | 1 + 5 files changed, 103 insertions(+), 11 deletions(-) create mode 100644 collects/racket/contract/private/box.rkt diff --git a/collects/mzlib/contract.rkt b/collects/mzlib/contract.rkt index e4101c8ba7..187db73fd0 100644 --- a/collects/mzlib/contract.rkt +++ b/collects/mzlib/contract.rkt @@ -30,6 +30,7 @@ ;; (require racket/contract/private/base + racket/contract/private/box racket/contract/private/hash racket/contract/private/misc racket/contract/private/provide @@ -45,6 +46,7 @@ contract-struct) (all-from-out racket/contract/private/base) + (all-from-out racket/contract/private/box) (all-from-out racket/contract/private/hash) (all-from-out racket/contract/private/provide) (except-out (all-from-out racket/contract/private/misc) diff --git a/collects/racket/contract/base.rkt b/collects/racket/contract/base.rkt index 7e48cfc855..b6d492b7e8 100644 --- a/collects/racket/contract/base.rkt +++ b/collects/racket/contract/base.rkt @@ -6,6 +6,7 @@ (require "private/arrow.rkt" "private/arr-i.rkt" "private/base.rkt" + "private/box.rkt" "private/hash.rkt" "private/misc.rkt" "private/provide.rkt" @@ -26,6 +27,7 @@ check-procedure/more make-contracted-function) (all-from-out "private/arr-i.rkt") + (all-from-out "private/box.rkt") (all-from-out "private/hash.rkt") (except-out (all-from-out "private/misc.rkt") check-between/c diff --git a/collects/racket/contract/private/box.rkt b/collects/racket/contract/private/box.rkt new file mode 100644 index 0000000000..f3513124ea --- /dev/null +++ b/collects/racket/contract/private/box.rkt @@ -0,0 +1,98 @@ +#lang racket/base + +(require (for-syntax racket/base) + "guts.rkt") + +(provide box-immutable/c box/c) + +(define-syntax (*-immutable/c stx) + (syntax-case stx () + [(_ predicate? constructor (arb? selectors ...) type-name name) + #'(*-immutable/c predicate? constructor (arb? selectors ...) type-name name #t)] + [(_ predicate? constructor (arb? selectors ...) type-name name test-immutable?) + (and (eq? #f (syntax->datum (syntax arb?))) + (boolean? (syntax->datum #'test-immutable?))) + (let ([test-immutable? (syntax->datum #'test-immutable?)]) + (with-syntax ([(params ...) (generate-temporaries (syntax (selectors ...)))] + [(p-apps ...) (generate-temporaries (syntax (selectors ...)))] + [(ctc-x ...) (generate-temporaries (syntax (selectors ...)))] + [(procs ...) (generate-temporaries (syntax (selectors ...)))] + [(selector-names ...) (generate-temporaries (syntax (selectors ...)))]) + #`(let ([predicate?-name predicate?] + [constructor-name constructor] + [selector-names selectors] ...) + (λ (params ...) + (let ([ctc-x (coerce-contract 'name params)] ...) + (if (and (flat-contract? ctc-x) ...) + (let ([p-apps (flat-contract-predicate ctc-x)] ...) + (build-flat-contract + `(name ,(contract-name ctc-x) ...) + (lambda (x) + (and (predicate?-name x) + (p-apps (selector-names x)) + ...)))) + (let ([procs (contract-projection ctc-x)] ...) + (make-contract + #:name (build-compound-type-name 'name ctc-x ...) + #:projection + (λ (blame) + (let ([p-apps (procs blame)] ...) + (λ (v) + (if #,(if test-immutable? + #'(and (predicate?-name v) + (immutable? v)) + #'(predicate?-name v)) + (constructor-name (p-apps (selector-names v)) ...) + (raise-blame-error + blame + v + #,(if test-immutable? + "expected immutable <~a>, given: ~e" + "expected <~a>, given: ~e") + 'type-name + v)))))))))))))] + [(_ predicate? constructor (arb? selector) correct-size type-name name) + (eq? #t (syntax->datum (syntax arb?))) + (syntax + (let ([predicate?-name predicate?] + [constructor-name constructor] + [selector-name selector]) + (λ params + (let ([ctcs (map (λ (param) (coerce-contract 'name param)) params)]) + (let ([procs (map contract-projection ctcs)]) + (make-contract + #:name (apply build-compound-type-name 'name ctcs) + #:projection + (λ (blame) + (let ([p-apps (map (λ (proc) (proc blame)) procs)] + [count (length params)]) + (λ (v) + (if (and (immutable? v) + (predicate?-name v) + (correct-size count v)) + (apply constructor-name + (let loop ([p-apps p-apps] + [i 0]) + (cond + [(null? p-apps) null] + [else (let ([p-app (car p-apps)]) + (cons (p-app (selector-name v i)) + (loop (cdr p-apps) (+ i 1))))]))) + (raise-blame-error + blame + v + "expected <~a>, given: ~e" + 'type-name + v)))))))))))])) + +(define box-immutable/c (*-immutable/c box? box-immutable (#f unbox) immutable-box box-immutable/c)) + +(define/final-prop (box/c pred) + (let* ([ctc (coerce-flat-contract 'box/c pred)] + [p? (flat-contract-predicate ctc)]) + (build-flat-contract + (build-compound-type-name 'box/c ctc) + (λ (x) + (and (box? x) + (p? (unbox x))))))) + diff --git a/collects/racket/contract/private/misc.rkt b/collects/racket/contract/private/misc.rkt index 956ba41a3a..2fc58e279d 100644 --- a/collects/racket/contract/private/misc.rkt +++ b/collects/racket/contract/private/misc.rkt @@ -22,7 +22,6 @@ symbols one-of/c listof non-empty-listof cons/c list/c vectorof vector-immutableof vector/c vector-immutable/c - box-immutable/c box/c promise/c struct/c syntax/c @@ -794,15 +793,6 @@ procs (vector->list v))))))) -(define/final-prop (box/c pred) - (let* ([ctc (coerce-flat-contract 'box/c pred)] - [p? (flat-contract-predicate ctc)]) - (build-flat-contract - (build-compound-type-name 'box/c ctc) - (λ (x) - (and (box? x) - (p? (unbox x))))))) - ;; ;; cons/c opter ;; @@ -982,7 +972,6 @@ (define cons/c-main-function (*-immutable/c pair? cons (#f car cdr) cons cons/c #f)) (define/subexpression-pos-prop (cons/c a b) (cons/c-main-function a b)) -(define box-immutable/c (*-immutable/c box? box-immutable (#f unbox) immutable-box box-immutable/c)) (define vector-immutable/c (*-immutable/c vector? vector-immutable (#t (λ (v i) (vector-ref v i))) diff --git a/collects/scribblings/reference/contracts.scrbl b/collects/scribblings/reference/contracts.scrbl index a876f3939b..b9d23e4bb7 100644 --- a/collects/scribblings/reference/contracts.scrbl +++ b/collects/scribblings/reference/contracts.scrbl @@ -20,6 +20,7 @@ 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/misc racket/contract/private/provide)]