racket/generic: allow impersonator contracts
This enables the use of polymorphic contracts with generic interfaces and their instances.
This commit is contained in:
parent
71e81f9fff
commit
a5d1007696
|
@ -128,7 +128,8 @@
|
|||
(vector (let ([mthd-generic (vector-ref generic-vector generic-idx)])
|
||||
(and mthd-generic
|
||||
(generic-arity-coerce mthd-generic)))
|
||||
...))))))
|
||||
...))
|
||||
null #t))))
|
||||
;; Hash table mapping method name symbols to
|
||||
;; whether the given method is implemented
|
||||
(define (defined-table this)
|
||||
|
@ -220,11 +221,11 @@
|
|||
[else val]))
|
||||
|
||||
;; projection for generic methods
|
||||
(define ((generic-instance/c-proj proxy-struct) ctc)
|
||||
(define ((generic-instance/c-proj proxy-struct proxy-vector) ctc)
|
||||
(λ (blame)
|
||||
;; for redirecting the method table accessor
|
||||
(define (redirect struct v)
|
||||
(chaperone-vector
|
||||
(proxy-vector
|
||||
v
|
||||
(method-table-redirect ctc blame)
|
||||
(λ (vec i v) v)))
|
||||
|
@ -266,13 +267,13 @@
|
|||
(struct chaperone-generic-instance/c base-generic-instance/c ()
|
||||
#:property prop:chaperone-contract
|
||||
(build-chaperone-contract-property
|
||||
#:projection (generic-instance/c-proj chaperone-struct)
|
||||
#:projection (generic-instance/c-proj chaperone-struct chaperone-vector)
|
||||
#:first-order generic-instance/c-first-order
|
||||
#:name generic-instance/c-name))
|
||||
|
||||
(struct impersonator-generic-instance/c base-generic-instance/c ()
|
||||
#:property prop:contract
|
||||
(build-contract-property
|
||||
#:projection (generic-instance/c-proj impersonate-struct)
|
||||
#:projection (generic-instance/c-proj impersonate-struct impersonate-vector)
|
||||
#:first-order generic-instance/c-first-order
|
||||
#:name generic-instance/c-name))
|
||||
|
|
59
collects/tests/generic/poly-contracts.rkt
Normal file
59
collects/tests/generic/poly-contracts.rkt
Normal file
|
@ -0,0 +1,59 @@
|
|||
#lang racket
|
||||
|
||||
;; generics with parametric contracts
|
||||
|
||||
(require rackunit)
|
||||
|
||||
(module stack racket
|
||||
(require racket/generic)
|
||||
|
||||
(define-generics stack
|
||||
(stack-push stack elem)
|
||||
(stack-pop stack)
|
||||
(stack-peek stack))
|
||||
|
||||
(define (make-stack/c elem/c)
|
||||
(define rec-stack/c (recursive-contract (make-stack/c elem/c)))
|
||||
(stack/c
|
||||
[stack-push (-> rec-stack/c elem/c rec-stack/c)]
|
||||
[stack-pop (-> rec-stack/c rec-stack/c)]
|
||||
[stack-peek (-> rec-stack/c elem/c)]))
|
||||
|
||||
(define elem/c (new-∀/c 'elem))
|
||||
|
||||
(provide gen:stack
|
||||
stack?
|
||||
make-stack/c
|
||||
;; generic functions have polymorphic contracts
|
||||
(contract-out
|
||||
[stack-push (-> (make-stack/c elem/c) elem/c (make-stack/c elem/c))]
|
||||
[stack-pop (-> (make-stack/c elem/c) (make-stack/c elem/c))]
|
||||
[stack-peek (-> (make-stack/c elem/c) elem/c)])))
|
||||
|
||||
(module instance racket
|
||||
(require (submod ".." stack))
|
||||
|
||||
(define-struct list-stack (l)
|
||||
#:methods gen:stack
|
||||
[(define (stack-push stack elem)
|
||||
(list-stack (cons elem (list-stack-l stack))))
|
||||
(define (stack-pop stack)
|
||||
(define lst (list-stack-l stack))
|
||||
(if (empty? lst)
|
||||
stack
|
||||
(list-stack (cdr lst))))
|
||||
(define (stack-peek stack)
|
||||
(car (list-stack-l stack)))])
|
||||
|
||||
(provide
|
||||
(contract-out
|
||||
;; specific instantiation of contract
|
||||
[list-stack (-> (listof symbol?) (make-stack/c symbol?))])))
|
||||
|
||||
(require 'stack 'instance)
|
||||
|
||||
(define stack (list-stack '(a b c)))
|
||||
|
||||
(check-true (stack? (stack-pop stack)))
|
||||
(check-equal? (stack-peek stack) 'a)
|
||||
(check-equal? (stack-peek (stack-push stack 'e)) 'e)
|
|
@ -10,4 +10,5 @@
|
|||
(submod "custom-write.rkt" test)
|
||||
"base-interfaces.rkt"
|
||||
"contract.rkt"
|
||||
"from-unstable.rkt")
|
||||
"from-unstable.rkt"
|
||||
"poly-contracts.rkt")
|
||||
|
|
Loading…
Reference in New Issue
Block a user