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

Initially just move the box-related combinators to a new location.

Browse Source
This commit is contained in:
Stevie Strickland 2010-05-13 14:20:39 -04:00
parent a838fa0606
commit b8fb6dae9a
5 changed files with 103 additions and 11 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
collects/mzlib/contract.rkt
View File

@ -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)

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

@ -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

98
collects/racket/contract/private/box.rkt Normal file
View File

@ -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)))))))

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

@ -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)))

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

@ -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)]