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

make parametric->/c do first-order checks for the argument/result

Browse Source 
contracts that it generates

closes PR 13600
This commit is contained in:
Robby Findler 2013-03-14 08:34:36 -05:00
parent 230f120a3d
commit 84ce7fa762
2 changed files with 86 additions and 14 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

29
collects/racket/contract/private/parametric.rkt
View File

@ -15,19 +15,17 @@
"expected an identifier"
stx
x)))
#'(make-polymorphic-contract 'parametric->/c
opaque/c
#'(make-polymorphic-contract opaque/c
'(x ...)
(lambda (x ...) c)))]))
(define-struct polymorphic-contract [title barrier vars body]
(define-struct polymorphic-contract [barrier vars body]
#:property prop:contract
(build-contract-property
#:name
(lambda (c)
(list (polymorphic-contract-title c)
(polymorphic-contract-vars c)
'...))
`(parametric->/c ,(polymorphic-contract-vars c) ...))
#:projection
(lambda (c)
(lambda (blame)
@ -71,15 +69,18 @@
#:property prop:contract
(build-contract-property
#:name (lambda (c) (barrier-contract-name c))
#:first-order (λ (c) (barrier-contract-pred c))
#:projection
(lambda (c)
(define mk (barrier-contract-make c))
(define pred (barrier-contract-pred c))
(define get (barrier-contract-get c))
(lambda (blame)
(if (equal? (blame-original? blame) (barrier-contract-positive? c))
(lambda (x)
((barrier-contract-make c) x))
(lambda (x)
(if ((barrier-contract-pred c) x)
((barrier-contract-get c) x)
(raise-blame-error blame x '(expected: "~a" given: "~e")
(barrier-contract-name c)
x))))))))
mk
(lambda (x)
(if (pred x)
(get x)
(raise-blame-error blame x '(expected: "~a" given: "~e")
(barrier-contract-name c)
x))))))))

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

@ -3616,7 +3616,78 @@
(test/pos-blame
'unconstrained-domain->7
'((contract (unconstrained-domain-> number?) (λ (#:x x) x) 'pos 'neg) #:x #f))
;
;
;
;
; ; ;;; ;
; ;;; ; ;
; ;;; ;; ;;;;; ;;; ;;;;;;; ;;; ;; ;;; ;;;; ;;;; ;;; ;;;; ;;; ;;;; ; ;;;
; ;;;;;;; ;;;;;;; ;;;;;;;;;;;; ;;;;;;;;;;; ;; ;;; ;;;; ;;;;;;;; ;;;;; ;;;;; ; ;;;;;
; ;;; ;;; ;; ;;; ;;; ;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;; ;; ; ;;; ;;
; ;;; ;;; ;;;;; ;;; ;;;;; ;;; ;;; ;;; ;;;;;;; ;;; ;;; ;;; ;;; ;;;; ;;;;; ; ;;;
; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;; ;;;; ;;;; ; ;;; ;;
; ;;;;;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;; ;;;;;; ;;;; ;;; ;;; ;;;;; ; ; ;;;;;
; ;;; ;; ;;;;;; ;;; ;;;;;; ;;; ;;; ;;; ;;;; ;;; ;;; ;;; ;;; ; ;;;
; ;;;
; ;;;
;
;
(test/spec-passed/result
'parametric->/c1
'((contract (parametric->/c (A) (-> A A))
(λ (x) x)
'pos 'neg)
1)
1)
(test/pos-blame
'parametric->/c2
'((contract (parametric->/c (A) (-> A A))
(λ (x) 1)
'pos 'neg)
1))
(test/pos-blame
'parametric->/c3
'((contract (parametric->/c (A B) (-> A B))
(λ (x) x)
'pos 'neg)
1))
;; this should (probably) not require the
;; application to 1, but parametric->/c
;; currently checks only that its argument
;; is a procedure and otherwise delays any
;; checking until the first application of
;; the wrapper
(test/pos-blame
'parametric->/c4
'((contract (parametric->/c (A) (-> A A))
(λ (x y) x)
'pos 'neg)
1))
(test/pos-blame
'parametric->/c5
'(contract (parametric->/c (A) (-> A A))
5
'pos 'neg))
(test/spec-passed/result
'parametric->/c6
'((contract (parametric->/c (A B) (-> A B (or/c A B)))
(λ (x y) x)
'pos 'neg)
1 "foo")
1)
;
;
;